diff --git a/cedar-lean/Cedar.lean b/cedar-lean/Cedar.lean index 092c63d83..d5110933c 100644 --- a/cedar-lean/Cedar.lean +++ b/cedar-lean/Cedar.lean @@ -15,6 +15,7 @@ -/ import Cedar.Data +import Cedar.Frontend import Cedar.Spec import Cedar.Thm import Cedar.Validation diff --git a/cedar-lean/Cedar/Frontend.lean b/cedar-lean/Cedar/Frontend.lean new file mode 100644 index 000000000..f83d44165 --- /dev/null +++ b/cedar-lean/Cedar/Frontend.lean @@ -0,0 +1,20 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +module + +public import Cedar.Frontend.Cst +public import Cedar.Frontend.Parser diff --git a/cedar-lean/Cedar/Frontend/Cst.lean b/cedar-lean/Cedar/Frontend/Cst.lean new file mode 100644 index 000000000..4e56e7d6e --- /dev/null +++ b/cedar-lean/Cedar/Frontend/Cst.lean @@ -0,0 +1,23 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +module + +public import Cedar.Frontend.Cst.Common +public import Cedar.Frontend.Cst.Syntax +public import Cedar.Frontend.Cst.Semantics +public import Cedar.Frontend.Cst.Slice +public import Cedar.Frontend.Cst.ToAst diff --git a/cedar-lean/Cedar/Frontend/Cst/Common.lean b/cedar-lean/Cedar/Frontend/Cst/Common.lean new file mode 100644 index 000000000..946c3ccea --- /dev/null +++ b/cedar-lean/Cedar/Frontend/Cst/Common.lean @@ -0,0 +1,292 @@ + +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +module + +public import Cedar.Frontend.Cst.Syntax +public import Cedar.Spec.Wildcard +public import Cedar.Spec.Policy + +namespace Cedar.Frontend.Cst + +open Cedar + + +public def Member.toLit? (e : Member) : Option Literal := + if !e.access.isEmpty then none else + match e.item with + | .literal l => some l + | _ => none + +-- TODO: Review this function, written by Claude + +public def hexDigitToNat? (c : Char) : Option Nat := + if '0' ≤ c ∧ c ≤ '9' then some (c.toNat - '0'.toNat) + else if 'a' ≤ c ∧ c ≤ 'f' then some (c.toNat - 'a'.toNat + 10) + else if 'A' ≤ c ∧ c ≤ 'F' then some (c.toNat - 'A'.toNat + 10) + else none + +public def toPatternAux (input : List Char) : Option Spec.Pattern := + match input with + | [] => some [] + | '\\' :: '*' :: cs => do let tail ← toPatternAux cs; some (.justChar '*' :: tail) + | '\\' :: '\\' :: cs => do let tail ← toPatternAux cs; some (.justChar '\\' :: tail) + | '\\' :: 'n' :: cs => do let tail ← toPatternAux cs; some (.justChar '\n' :: tail) + | '\\' :: 'r' :: cs => do let tail ← toPatternAux cs; some (.justChar '\r' :: tail) + | '\\' :: 't' :: cs => do let tail ← toPatternAux cs; some (.justChar '\t' :: tail) + | '\\' :: '0' :: cs => do let tail ← toPatternAux cs; some (.justChar '\x00' :: tail) + | '\\' :: '"' :: cs => do let tail ← toPatternAux cs; some (.justChar '"' :: tail) + | '\\' :: '\'' :: cs => do let tail ← toPatternAux cs; some (.justChar '\'' :: tail) + | '\\' :: 'u' :: '{' :: cs => + let digits := cs.takeWhile (· ≠ '}') + let afterBrace := cs.drop digits.length + match h : afterBrace with + | '}' :: remaining => do + if digits.isEmpty ∨ digits.length > 6 then none else do + let codepoint ← digits.foldlM (fun acc d => do + let v ← hexDigitToNat? d + some (acc * 16 + v)) 0 + if codepoint > 0x10FFFF then none + let tail ← toPatternAux remaining + some (.justChar (Char.ofNat codepoint) :: tail) + | _ => none + | '\\' :: _ => none + | '*' :: cs => do let tail ← toPatternAux cs; some (.star :: tail) + | c :: cs => do let tail ← toPatternAux cs; some (.justChar c :: tail) +termination_by input.length +decreasing_by + all_goals simp_wf + all_goals (try omega) + · have h1 : digits.length ≤ cs.length := + List.IsPrefix.length_le (List.takeWhile_prefix _) + have h2 : afterBrace.length = cs.length - digits.length := by + simp [afterBrace, List.length_drop] + have h3 : remaining.length + 1 = afterBrace.length := by + simp [h] + omega + +public def toPattern? (s : String) : Option Spec.Pattern := + toPatternAux s.toList + +public def unescapeAux (input : List Char) : Option (List Char) := + match input with + | [] => some [] + | '\\' :: 'n' :: cs => do let tail ← unescapeAux cs; some ('\n' :: tail) + | '\\' :: 'r' :: cs => do let tail ← unescapeAux cs; some ('\r' :: tail) + | '\\' :: 't' :: cs => do let tail ← unescapeAux cs; some ('\t' :: tail) + | '\\' :: '0' :: cs => do let tail ← unescapeAux cs; some ('\x00' :: tail) + | '\\' :: '\\' :: cs => do let tail ← unescapeAux cs; some ('\\' :: tail) + | '\\' :: '"' :: cs => do let tail ← unescapeAux cs; some ('"' :: tail) + | '\\' :: '\'' :: cs => do let tail ← unescapeAux cs; some ('\'' :: tail) + | '\\' :: 'u' :: '{' :: cs => + let digits := cs.takeWhile (· ≠ '}') + let afterBrace := cs.drop digits.length + match h : afterBrace with + | '}' :: remaining => do + if digits.isEmpty ∨ digits.length > 6 then none else do + let codepoint ← digits.foldlM (fun acc d => do + let v ← hexDigitToNat? d + some (acc * 16 + v)) 0 + if codepoint > 0x10FFFF then none + let tail ← unescapeAux remaining + some (Char.ofNat codepoint :: tail) + | _ => none + | '\\' :: _ => none + | c :: cs => do + let tail ← unescapeAux cs + some (c :: tail) +termination_by input.length +decreasing_by + all_goals simp_wf + all_goals (try omega) + · have h1 : digits.length ≤ cs.length := + List.IsPrefix.length_le (List.takeWhile_prefix _) + have h2 : afterBrace.length = cs.length - digits.length := by + simp [afterBrace, List.length_drop] + have h3 : remaining.length + 1 = afterBrace.length := by + simp [h] + omega + +public def unescape? (s : String) : Option String := do + let chars ← unescapeAux s.toList + some (String.ofList chars) + +public def Unreserved? (s : String) : Bool := + match s with + | "principal" => false + | "action" => false + | "resource" => false + | "context" => false + | "true" => false + | "false" => false + | "permit" => false + | "forbid" => false + | "when" => false + | "unless" => false + | "in" => false + | "has" => false + | "like" => false + | "is" => false + | "if" => false + | "then" => false + | "else" => false + | _ => true + +public theorem unreserved_iff_not_in_keywords {s : String} : + Unreserved? s = true ↔ s ∉ keywords := by + simp only [Unreserved?, keywords, List.mem_cons, not_or, List.mem_nil_iff, + not_false_eq_true, and_true] + constructor + · intro h + split at h <;> simp_all + · intro ⟨h1, h2, h3, h4, h5, h6, h7, h8, h9, h10, h11, h12, h13, h14, h15, h16, h17⟩ + split <;> simp_all + +public theorem not_in_keywords_unreserved {s : String} (h : s ∉ keywords) : + Unreserved? s = true := + unreserved_iff_not_in_keywords.mpr h + +public def Ident.toUnreservedString? : Ident → Option String + | .idIdent s _ => if (Unreserved? s) then some s else none + | _ => none + +@[simp] +public theorem Ident.toUnreservedString?_idIdent (s : String) (h : s ∉ keywords) : + Ident.toUnreservedString? (.idIdent s h) = some s := by + simp [Ident.toUnreservedString?, not_in_keywords_unreserved h] + +@[simp] +public theorem Ident.toString_idIdent (s : String) (h : s ∉ keywords) : + Ident.toString (.idIdent s h) = s := rfl + +/-- Convert an identifier to its string form, accepting variable/keyword + identifiers that are valid as (parts of) entity-type names but rejecting + the reserved keywords (`true`, `false`, `in`, `has`, `like`, `is`, `if`, + `then`, `else`). Shared by the translator (`Name.toAName?`) and the + evaluator. -/ +public def Ident.toUnrestrictedString? : Ident → Option String + | .idPrincipal => some "principal" + | .idAction => some "action" + | .idResource => some "resource" + | .idContext => some "context" + | .idPermit => some "permit" + | .idForbid => some "forbid" + | .idWhen => some "when" + | .idUnless => some "unless" + | .idIdent s _ => some s + | _ => none + +/-- Convert a CST name to an AST entity-type `Name`, failing if any component + is a reserved keyword. Shared by the translator and the evaluator. -/ +public def Name.toAName? (n : Name) : Option Spec.Name := do + let id ← Ident.toUnrestrictedString? n.name + let path ← n.path.mapM Ident.toUnrestrictedString? + some {id := id, path := path} + +public def Ident.toEffect? : Ident → Option Spec.Effect + | .idPermit => some .permit + | .idForbid => some .forbid + | _ => none + +public def Expr.toStringLiteral? : Expr → Option String + | .expr e => match e.expr with + | .edIf _ _ _ => none + | .edOr e => match e.initial.initial with + | .rHas _ _ => none + | .rLike _ _ => none + | .rCommon i _ => match i.initial.initial.item.item with + | .literal l => match l with + | .liStr s => some s + | _ => none + | _ => none + | .rIsIn _ _ _ => none + +public def Expr.toUnescapedStringLiteral? (e : Expr) : Option String := do + let s ← Expr.toStringLiteral? e + unescape? s + +public def String.isFunctionName? : String → Bool + | "decimal" ----- Decimal functions ----- + | "lessThan" + | "lessThanOrEqual" + | "greaterThan" + | "greaterThanOrEqual" + | "ip" ----- IpAddr functions ----- + | "isIpv4" + | "isIpv6" + | "isLoopback" + | "isMulticast" + | "isInRange" + | "datetime" ----- Datetime functions ----- + | "duration" + | "offset" + | "durationSince" + | "toDate" + | "toTime" + | "toMilliseconds" + | "toSeconds" + | "toMinutes" + | "toHours" + | "toDays" => true + | _ => false + +public def String.toExtFun? : String → Option Spec.ExtFun + | "decimal" => some .decimal + | "lessThan" => some .lessThan + | "lessThanOrEqual" => some .lessThanOrEqual + | "greaterThan" => some .greaterThan + | "greaterThanOrEqual" => some .greaterThanOrEqual + | "ip" => some .ip + | "isIpv4" => some .isIpv4 + | "isIpv6" => some .isIpv6 + | "isLoopback" => some .isLoopback + | "isMulticast" => some .isMulticast + | "isInRange" => some .isInRange + | "datetime" => some .datetime + | "duration" => some .duration + | "offset" => some .offset + | "durationSince" => some .durationSince + | "toDate" => some .toDate + | "toTime" => some .toTime + | "toMilliseconds" => some .toMilliseconds + | "toSeconds" => some .toSeconds + | "toMinutes" => some .toMinutes + | "toHours" => some .toHours + | "toDays" => some .toDays + | _ => none + +public def String.isMethodName? : String → Bool + | "contains" + | "containsAll" + | "containsAny" + | "isEmpty" + | "getTag" + | "hasTag" => true + | _ => false + +public def String.toMethodOp? : String → Option (Spec.BinaryOp ⊕ Spec.UnaryOp) + | "contains" => some (.inl .contains) + | "containsAll" => some (.inl .containsAll) + | "containsAny" => some (.inl .containsAny) + | "getTag" => some (.inl .getTag) + | "hasTag" => some (.inl .hasTag) + | "isEmpty" => some (.inr .isEmpty) + | _ => none + + + +end Cedar.Frontend.Cst diff --git a/cedar-lean/Cedar/Frontend/Cst/Semantics.lean b/cedar-lean/Cedar/Frontend/Cst/Semantics.lean new file mode 100644 index 000000000..75fb7b673 --- /dev/null +++ b/cedar-lean/Cedar/Frontend/Cst/Semantics.lean @@ -0,0 +1,745 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + + +module + +public import Cedar.Frontend.Cst.Syntax +public import Cedar.Spec.Entities +public import Cedar.Spec.Request +public import Cedar.Spec.Response +public import Cedar.Spec.Value +public import Cedar.Spec.Evaluator +public import Cedar.Frontend.Cst.ToAst + +namespace Cedar.Frontend.Cst + +open Cedar.Data +open Cedar + + +-- The hierarchy of Expr in the CST +-- Expr → ExprImpl → ExprData → OrExpr → AndExpr → Relation +-- → AddExpr → MultExpr → Unary → Member → Primary + +/- Evaluator helpers -/ + +public def AttrChain? (ms : List MemAccess) : Option (List Spec.Attr) := + match ms with + | [] => some [] + | m :: ms => match m with + | .field i => match (Ident.toUnreservedString? i) with + | none => none + | some s => (AttrChain? ms).map (s :: ·) + | .index e => match (Expr.toUnescapedStringLiteral? e) with + | none => none + | some s => (AttrChain? ms).map (s :: ·) + | .call _ => none + +private def Member.toAttrs? (e : Member) : Option (List Spec.Attr) := + match AttrChain? e.access with + | none => none + | some attrs => match e.item with + | .literal (.liStr s) => + if attrs.isEmpty then some [s] else none + | .literal _ => none + | .name { path := [], name := id } => match (Ident.toUnreservedString? id) with + | some s => some (s :: attrs) + | none => none + | .name _ => none + | _ => none + +/-- Attribute name of an identifier used as a record key, read structurally + (no translation). Reserved keywords map to their spellings; ordinary + identifiers map to themselves; `true`/`false`/`in`/`has`/… are rejected. -/ +public def Ident.toAttr? : Ident → Option Spec.Attr + | .idPrincipal => some "principal" + | .idAction => some "action" + | .idResource => some "resource" + | .idContext => some "context" + | .idPermit => some "permit" + | .idForbid => some "forbid" + | .idWhen => some "when" + | .idUnless => some "unless" + | .idIdent s _ => some s + | _ => none + +/-- Attribute name of a `Primary` used as a record key. -/ +public def Primary.toAttr? (p : Primary) : Option Spec.Attr := + match p with + | .literal (.liStr s) => unescape? s + | .name { path := [], name := id } => Ident.toAttr? id + | _ => none + +/-- Extract a record-key attribute name from a CST expression, without + translating it: the key must be a "bare" primary (no operators other than a + no-op `-0`, no extended chains, no member accesses) that is a string literal + or an identifier name. This matches the keys the translator accepts. -/ +public def Expr.toAttr? (e : Expr) : Option Spec.Attr := + match e with + | .expr ⟨.edIf _ _ _⟩ => none + | .expr ⟨.edOr o⟩ => + if !o.extended.isEmpty || !o.initial.extended.isEmpty then none + else match o.initial.initial with + | .rCommon ae ext => + if !ext.isEmpty || !ae.extended.isEmpty || !ae.initial.extended.isEmpty + || !ae.initial.initial.item.access.isEmpty then none + else match ae.initial.initial.op with + | none => Primary.toAttr? ae.initial.initial.item.item + | some (.nDash 0) => Primary.toAttr? ae.initial.initial.item.item + | _ => none + | _ => none + +-- RelOp: rLess, rLessEq, rGreaterEq, rGreater, rNotEq, rEq, rIn +-- `rGreater`/`rGreaterEq` use the `not (less/lessEq v₁ v₂)` pattern to match +-- the translator's `constructExprRel`. Behaviorally equivalent on totally- +-- comparable values; for other values, the `apply₂` errors propagate through +-- the `not` consistently with the translator's AST output. +public def applyRelOp (op : RelOp) (v₁ v₂ : Spec.Value) (es : Spec.Entities) : Spec.Result Spec.Value := + match op with + | .rLess => Spec.apply₂ .less v₁ v₂ es + | .rLessEq => Spec.apply₂ .lessEq v₁ v₂ es + | .rGreater => do + let r ← Spec.apply₂ .lessEq v₁ v₂ es + Spec.apply₁ .not r + | .rGreaterEq => do + let r ← Spec.apply₂ .less v₁ v₂ es + Spec.apply₁ .not r + | .rEq => Spec.apply₂ .eq v₁ v₂ es + | .rNotEq => do + let eq ← Spec.apply₂ .eq v₁ v₂ es + Spec.apply₁ .not eq + | .rIn => Spec.apply₂ .mem v₁ v₂ es + +-- When the list is all `.field id` with `id` unreserved, return the converted +-- list of `Attr`s. Otherwise return `none`. Matches the translator's +-- `constructAttrsAux?` filter. +public def fieldChain? : List MemAccess → Option (List Spec.Attr) + | [] => some [] + | .field id :: xs => do + let head ← Ident.toUnreservedString? id + let tail ← fieldChain? xs + some (head :: tail) + | _ :: _ => none + +-- Head string for a name appearing at the start of a `has` field chain. +-- Mirrors the translator's two paths: +-- * `.var v` arm (when `n.toVar? = some v`): use `v.toString` directly, +-- allowing the four var idents through without an unreserved check. +-- * `.name an` arm (when `n.toVar? = none`): filter via `toUnreservedId?`, +-- accepting only `.idIdent s` with `s` unreserved. +public def Ident.toHasHead? : Cst.Ident → Option String + | .idPrincipal => some "principal" + | .idAction => some "action" + | .idResource => some "resource" + | .idContext => some "context" + | .idIdent s _ => if Unreserved? s then some s else none + | _ => none + +public def AddExpr.toAttrs? (e : AddExpr) : Option (List Spec.Attr) := + if !e.extended.isEmpty then none else + let mult := e.initial + if !mult.extended.isEmpty then none else + let unary := mult.initial + match unary.op with + | some _ => none + | none => let member := unary.item + match fieldChain? member.access with + | none => none + | some fields => match member.item with + | .literal (.liStr s) => + -- Apply unescape? to mirror the translator's `(unescape? lit).map .inl`. + if fields.isEmpty then (unescape? s).map (fun s' => [s']) + else none + | .literal _ => none + | .name { path := [], name := id } => + -- Mirror the translator's combined `.var v` / `.name n` arms via + -- the helper above. + match Ident.toHasHead? id with + | some idStr => some (idStr :: fields) + | none => none + | .name _ => none + | _ => none + +-- Only Literal.liStr s is allowed +-- Mirrors the translator's `Cst.AddExpr.toPattern?`: the unary `op` may be +-- `none` or `some (.nDash 0)` (a structural no-op that the translator allows). +public def AddExpr.toPatternString? (e : AddExpr) : Option String := + if !e.extended.isEmpty then none else + let mult := e.initial + if !mult.extended.isEmpty then none else + let unary := mult.initial + match unary.op with + | some (.nDash 0) | none => + let member := unary.item + if !member.access.isEmpty then none else + let item := member.item + match item with + | .literal (.liStr s) => some s + | _ => none + | some _ => none + +-- Extracts an EntityType (Spec.Name) from an AddExpr that is a bare name. +public def AddExpr.toEntityTypeName? (e : AddExpr) : Option Spec.EntityType := + if !e.extended.isEmpty then none else + let mult := e.initial + if !mult.extended.isEmpty then none else + let unary := mult.initial + match unary.op with + | some (.nDash 0) | none => + let member := unary.item + if !member.access.isEmpty then none else + match member.item with + | .name n => Name.toAName? n + | _ => none + | some _ => none + +/- Evaluators -/ + +public def Str.toUnescapedString : Str → Spec.Result String + | .string s => match unescape? s with + | some s' => .ok s' + | none => .error (.cstError .stringError) + +/-- Evaluate the chain of attribute checks for `r has a₀.a₁.….aₙ` with + short-circuiting on the inner `Spec.hasAttr` returning `false`. Mirrors the + translator's `extendedHasAttr`, which builds nested `.and (Spec.hasAttr ...) ...`. -/ +public def rHasChain (v : Spec.Value) (a : Spec.Attr) (rest : List Spec.Attr) (es : Spec.Entities) : Spec.Result Spec.Value := + match rest with + | [] => Spec.hasAttr v a es + | b :: bs => do + let h ← Spec.hasAttr v a es + match h with + | .prim (.bool false) => .ok (.prim (.bool false)) + | _ => do + let v' ← Spec.getAttr v a es + rHasChain v' b bs es +termination_by sizeOf rest + +mutual + +public def Primary.evaluate (e : Primary) (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := + match e with + | .literal l => match l with + | .liTrue => .ok (.prim (.bool true)) + | .liFalse => .ok (.prim (.bool false)) + | .liNum n => match Int64.ofInt? n.toNat with + | some i => .ok (.prim (.int i)) + | none => .error .arithBoundsError + | .liStr s => do + let s' ← Str.toUnescapedString (.string s) + .ok (.prim (.string s')) + | .name n => + if !n.path.isEmpty then .error (.cstError .nameError) + else match n.name with + | .idPrincipal => .ok (.prim (.entityUID req.principal)) + | .idAction => .ok (.prim (.entityUID req.action)) + | .idResource => .ok (.prim (.entityUID req.resource)) + | .idContext => .ok (.record req.context) + | _ => .error (.cstError .nameError) + | .expr e => e.evaluate req es + | .eList xs => do + let vs ← xs.mapM (fun x => x.evaluate req es) + .ok (.set (Set.make vs)) + | .ref r => match r with + | .uid path eid => do + let eid' ← Str.toUnescapedString eid + match Name.toAName? path with + | some etype => .ok (.prim (.entityUID { ty := etype, eid := eid' })) + | none => .error (.cstError .unsupportedError) + | .ref _ _ => .error (.cstError .unsupportedError) + | .rInits r => do + let avs ← r.mapM₁ (fun ⟨ri, hmem⟩ => + have : sizeOf ri.value < 1 + sizeOf r := by + have h1 := List.sizeOf_lt_of_mem hmem + obtain ⟨k, v⟩ := ri + simp only [RecInit.mk.sizeOf_spec] at h1 + show sizeOf v < 1 + sizeOf r + omega + match ri.attr.toAttr? with + | none => .error (.cstError .stringError) + | some attr => do + let val ← ri.value.evaluate req es + .ok (attr, val)) + .ok (.record (Map.make avs)) + | .slot _ => .error (.cstError .unsupportedError) +termination_by sizeOf e + +public def Member.evaluate (e : Member) (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := + match e with + -- Function calls + | { item := .name { path := [], name := .idIdent s _ }, access := .call args :: rest } => + match String.toExtFun? s with + | none => .error (.cstError .unsupportedError) + | some xfn => do + let args ← args.mapM (fun a => a.evaluate req es) + let v ← Spec.call xfn args + Member.evalAccessors v rest req es + -- Accessors + | { item := item, access := access } => do + let head ← item.evaluate req es + Member.evalAccessors head access req es +termination_by sizeOf e +decreasing_by + all_goals simp_wf + all_goals first + | omega + | (have := List.sizeOf_lt_of_mem (by assumption); omega) + +public def Member.evalAccessors (head : Spec.Value) (accs : List MemAccess) + (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := + match accs with + | [] => .ok head + -- Method call `recv.m(args)`: a field naming the method, then its arguments. + | .field i :: .call args :: rest => + match Ident.toUnreservedString? i with + | none => .error (.cstError .stringError) + | some m => match String.toMethodOp? m with + | some (.inl bop) => match args with + | [arg] => do + let argVal ← arg.evaluate req es + let v ← Spec.apply₂ bop head argVal es + Member.evalAccessors v rest req es + | _ => .error (.cstError .arityError) + | some (.inr uop) => + if args.isEmpty then do + let v ← Spec.apply₁ uop head + Member.evalAccessors v rest req es + else .error (.cstError .arityError) + | none => .error (.cstError .unsupportedError) + -- Attribute access `recv.attr`. + | .field i :: rest => + match Ident.toUnreservedString? i with + | none => .error (.cstError .stringError) + | some attr => do + let v ← Spec.getAttr head attr es + Member.evalAccessors v rest req es + -- Indexed attribute access `recv["attr"]`. + | .index ex :: rest => + match Expr.toUnescapedStringLiteral? ex with + | none => .error (.cstError .stringError) + | some attr => do + let v ← Spec.getAttr head attr es + Member.evalAccessors v rest req es + -- A call with no preceding field accessor is a call on a non-name value, + -- which the translator rejects. + | .call _ :: _ => .error (.cstError .unsupportedError) +termination_by sizeOf accs +decreasing_by + all_goals simp_wf + all_goals omega + +-- NegOp: nBang i, nOverBang, nDash i, nOverDash +-- The `.nDash` numeric-literal case is handled specially so that the value +-- `-(Int64.MAX + 1) = Int64.MIN` is representable, matching the AST translator. +public def Unary.evaluate (e : Unary) (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := + match e.op with + | none => e.item.evaluate req es + | some (.nBang n) => + if n == 0 then e.item.evaluate req es else do + let mval ← e.item.evaluate req es + -- error the non-bool + match mval with + | .prim (.bool b) => + if n % 2 == 0 then .ok (.prim (.bool b)) else .ok (.prim (.bool !b)) + | _ => .error .typeError + | some (.nDash n) => + if n == 0 then e.item.evaluate req es else + match Member.toLit? e.item with + | some (.liNum x) => + let xNat := x.toNat + let minMagnitude := (Int64.MAX + 1).toNat + match compare xNat minMagnitude with + | .eq => + -- AST translates to `(lit Int64.MIN).dashN (n-1)`. Since + -- `Int64.MIN.neg?` fails, only `n = 1` succeeds (zero further + -- negations applied); any larger `n` errors on the first negation. + if n == 1 + then .ok (.prim (.int Int64.MIN.toInt64)) + else .error .arithBoundsError + | .lt => + match Int64.ofInt? (Int.ofNat xNat) with + | some y => + if n % 2 == 0 then .ok (.prim (.int y)) else .ok (.prim (.int (-y))) + | none => .error .arithBoundsError + | .gt => .error .arithBoundsError + | _ => do + let mval ← e.item.evaluate req es + -- Force the type check and error the non-ints. We must also check + -- `i.neg?` *before* the parity shortcut: when `i = Int64.MIN`, the + -- AST iterates `apply₁ .neg` and errors on the first step, so this + -- case must error regardless of parity. + match mval with + | .prim (.int i) => + match i.neg? with + | none => .error .arithBoundsError + | some j => + if n % 2 == 0 then .ok (.prim (.int i)) + else .ok (.prim (.int j)) + | _ => .error .typeError +termination_by sizeOf e +decreasing_by + all_goals cases e; simp_wf; omega + +public def MultExpr.evaluate (e : MultExpr) (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := do + let b ← e.initial.evaluate req es + MultExpr.foldOps b e.extended req es +termination_by sizeOf e +decreasing_by + all_goals cases e; simp_wf; omega + +-- Division and Modulo are rejected in cst_to_ast.rs +public def MultExpr.foldOps (acc : Spec.Value) (xs : List (MultOp × Unary)) + (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := + match xs with + | [] => .ok acc + | (op, u) :: rest => do + let aval ← u.evaluate req es + let acc' ← match op with + | .mTimes => Spec.apply₂ .mul acc aval es + | _ => .error (.cstError .unsupportedError) + MultExpr.foldOps acc' rest req es +termination_by sizeOf xs + +public def AddExpr.evaluate (e : AddExpr) (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := do + let b ← e.initial.evaluate req es + AddExpr.foldOps b e.extended req es +termination_by sizeOf e +decreasing_by + all_goals cases e; simp_wf; omega + +public def AddExpr.foldOps (acc : Spec.Value) (xs : List (AddOp × MultExpr)) + (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := + match xs with + | [] => .ok acc + | (op, m) :: rest => do + let aval ← m.evaluate req es + let acc' ← match op with + | .aPlus => Spec.apply₂ .add acc aval es + | .aMinus => Spec.apply₂ .sub acc aval es + AddExpr.foldOps acc' rest req es +termination_by sizeOf xs + +public def Relation.evaluate (e : Relation) (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := + match e with + -- `RelOp` cannot be chained + | .rCommon x xs => match xs with + | [] => x.evaluate req es + | [(op, y)] => do + let v₁ ← x.evaluate req es + let v₂ ← y.evaluate req es + applyRelOp op v₁ v₂ es + | _ => .error (.cstError .unsupportedError) + | .rHas t f => do + let v ← t.evaluate req es + match f.toAttrs? with + | none => .error (.cstError .unsupportedError) + | some [] => .error (.cstError .unsupportedError) + | some (a :: as) => + -- For `r has x.y.z`: short-circuit on `false` between getAttr steps, + -- mirroring the translator's `.and (hasAttr ...) (extendedHasAttr ...)` + -- which short-circuits on the inner `hasAttr` returning `false`. + rHasChain v a as es + | .rLike t p => match p.toPatternString? with + | none => .error (.cstError .stringError) + | some s => do + let v ← t.evaluate req es + match toPattern? s with + | some p => Spec.apply₁ (.like p) v + | none => .error (.cstError .stringError) + | .rIsIn t ety inEntity => match ety.toEntityType? with + | none => .error (.cstError .nameError) + | some etyName => do + let v ← t.evaluate req es + let isResult ← Spec.apply₁ (.is etyName) v + match inEntity with + | none => .ok isResult + | some ie => + -- Strengthening: fail the evaluation when the `in` branch does not + -- translate, even if the `is` branch short-circuits to `false`. Under a + -- successful translation `ie.toAExpr?.isSome` holds, so this guard is a + -- no-op and the evaluator still agrees with the short-circuiting AST; + -- but it lets a successful evaluation witness that `ie` translates, + -- which is needed for translation completeness. + if ie.toAExpr?.isNone then .error (.cstError .translationError) + else do + let b ← isResult.asBool + if !b then .ok false + else do + let v₂ ← ie.evaluate req es + Spec.apply₂ .mem v v₂ es +termination_by sizeOf e + +public def AndExpr.evaluate (e : AndExpr) (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := + -- Strengthening (mirrors the `rIsIn` guard): fail when some + -- conjunct does not translate, even if `foldOps` short-circuits past it on a + -- `false`. Under a successful translation every conjunct translates, so this + -- guard is a no-op and the evaluator still agrees with the short-circuiting + -- AST; but it lets a successful evaluation witness that every conjunct + -- translates, which completeness needs. + if e.extended.all (fun r => r.toAExpr?.isSome) then do + let acc ← e.initial.evaluate req es + AndExpr.foldOps acc e.extended req es + else .error (.cstError .translationError) +termination_by sizeOf e +decreasing_by + all_goals cases e; simp_wf; omega + +-- Mirrors the AST `Expr.and acc rel` evaluation: coerce acc to Bool, short-circuit +-- on `false`, otherwise coerce rel.evaluate to Bool, wrap as a Value, recurse. +public def AndExpr.foldOps (acc : Spec.Value) (xs : List Relation) + (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := + match xs with + | [] => .ok acc + | x :: rest => do + let b ← acc.asBool + if !b then .ok (.prim (.bool false)) else do + let b' ← (x.evaluate req es).as Bool + AndExpr.foldOps (.prim (.bool b')) rest req es +termination_by sizeOf xs + +public def OrExpr.evaluate (e : OrExpr) (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := + -- Strengthening (mirrors `AndExpr.evaluate`): fail when some disjunct does not + -- translate, even if `foldOps` short-circuits past it on a `true`. Under a + -- successful translation every disjunct translates, so this guard is a no-op + -- and the evaluator still agrees with the short-circuiting AST; but it lets a + -- successful evaluation witness that every disjunct translates. + if e.extended.all (fun r => r.toAExpr?.isSome) then do + let acc ← e.initial.evaluate req es + OrExpr.foldOps acc e.extended req es + else .error (.cstError .translationError) +termination_by sizeOf e +decreasing_by + all_goals cases e; simp_wf; omega + +-- Mirrors the AST `Expr.or acc rhs` evaluation: coerce acc to Bool, short-circuit +-- on `true`, otherwise coerce rhs.evaluate to Bool, wrap as a Value, recurse. +public def OrExpr.foldOps (acc : Spec.Value) (xs : List AndExpr) + (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := + match xs with + | [] => .ok acc + | x :: rest => do + let b ← acc.asBool + if b then .ok (.prim (.bool true)) else do + let b' ← (x.evaluate req es).as Bool + OrExpr.foldOps (.prim (.bool b')) rest req es +termination_by sizeOf xs + +public def ExprData.evaluate (e : ExprData) (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := + match e with + | .edOr e => e.evaluate req es + | .edIf i t f => + -- Strengthening (mirrors the `rIsIn` `in` guard): the guard `i` is always + -- evaluated, but only one of `t`/`f` is (the conditional short-circuits), so + -- we only fail when a *branch* `t`/`f` does not translate. Under a successful + -- translation both branches translate, so this guard is a no-op and the + -- evaluator still agrees with the AST `ite`; but it lets a successful + -- evaluation witness that both branches translate (completeness recovers + -- `i`'s translatability from the fact that `i` is always evaluated). + if t.toAExpr?.isSome && f.toAExpr?.isSome then do + let b ← (i.evaluate req es).as Bool + if b then t.evaluate req es else f.evaluate req es + else .error (.cstError .translationError) +termination_by sizeOf e + +public def ExprImpl.evaluate (e : ExprImpl) (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := + e.expr.evaluate req es +termination_by sizeOf e +decreasing_by cases e; simp_wf + +public def Expr.evaluate (e : Expr) (req : Spec.Request) (es : Spec.Entities) : Spec.Result Spec.Value := + match e with + | .expr e => e.evaluate req es +termination_by sizeOf e + +end + +/- Lifting helpers -/ + +public def Expr.toPrimary (e : Expr) : Primary := + .expr e + +public def Primary.toMember (p : Primary) : Member := + {item := p, access := []} + +public def Member.toUnary (m : Member) : Unary := + {op := none, item := m} + +public def Unary.toMultExpr (u : Unary) : MultExpr := + {initial := u, extended := []} + +public def MultExpr.toAddExpr (m : MultExpr) : AddExpr := + {initial := m, extended := []} + +public def AddExpr.toRelation (a : AddExpr) : Relation := + .rCommon a [] + +public def Relation.toAndExpr (r : Relation) : AndExpr := + {initial := r, extended := []} + +public def AndExpr.toOrExpr (a : AndExpr) : OrExpr := + {initial := a, extended := []} + +public def OrExpr.toExpr (o : OrExpr) : Expr := + .expr {expr := .edOr o} + +public def Expr.lift (e : Expr) : Expr := + e.toPrimary.toMember.toUnary.toMultExpr.toAddExpr.toRelation.toAndExpr.toOrExpr.toExpr + +/- Other lifting helpers -/ + +public def Expr.toRelation (e : Expr) : Relation := + e.toPrimary.toMember.toUnary.toMultExpr.toAddExpr.toRelation + +public def Expr.toAddExpr (e : Expr) : AddExpr := + e.toPrimary.toMember.toUnary.toMultExpr.toAddExpr + +public def Ident.varToAddExpr (id : Ident) : AddExpr := + (Primary.name {path := [], name := id}).toMember.toUnary.toMultExpr.toAddExpr + +/- Constants and Combinators on Expr -/ + +public def Relation.tt : Relation := + (Primary.literal Literal.liTrue).toMember.toUnary.toMultExpr.toAddExpr.toRelation + +public def Relation.ff : Relation := + (Primary.literal Literal.liFalse).toMember.toUnary.toMultExpr.toAddExpr.toRelation + +public def Expr.tt : Expr := + (Primary.literal Literal.liTrue).toMember.toUnary.toMultExpr.toAddExpr.toRelation.toAndExpr.toOrExpr.toExpr + +public def Expr.ff : Expr := + (Primary.literal Literal.liFalse).toMember.toUnary.toMultExpr.toAddExpr.toRelation.toAndExpr.toOrExpr.toExpr + +public def Expr.not (e : Expr) : Expr := + let e' : Unary := {op := NegOp.nBang 1, item := e.toPrimary.toMember} + e'.toMultExpr.toAddExpr.toRelation.toAndExpr.toOrExpr.toExpr + +public def Expr.and (e1 e2 : Expr) : Expr := + let e1' := e1.toPrimary.toMember.toUnary.toMultExpr.toAddExpr.toRelation + let e2' := e2.toPrimary.toMember.toUnary.toMultExpr.toAddExpr.toRelation + let e' : AndExpr := {initial := e1', extended := [e2']} + e'.toOrExpr.toExpr + +public def Expr.or (e1 e2 : Expr) : Expr := + let e1' := e1.toPrimary.toMember.toUnary.toMultExpr.toAddExpr.toRelation.toAndExpr + let e2' := e2.toPrimary.toMember.toUnary.toMultExpr.toAddExpr.toRelation.toAndExpr + let e' : OrExpr := {initial := e1', extended := [e2']} + e'.toExpr + +-- Check whether this is needed +-- public def andReduce : List Expr → List Expr +-- | [] => [] +-- | Expr.tt :: es => andReduce es +-- | e :: es => e :: (andReduce es) + +public def Expr.foldAnd : List Expr → Expr + | [] => Expr.tt + | [e] => e + | e :: es => + let e' := e.toRelation + let es' := es.map Expr.toRelation + let a : AndExpr := { initial := e', extended := es' } + a.toOrExpr.toExpr + +/- Conversion to Expr -/ + +public def VariableDef.toAndExpr (vd : VariableDef) : AndExpr := + let var' := vd.var.varToAddExpr + match vd.entityType, vd.ineq with + | some et, some (.rIn, e) => + {initial := Relation.rIsIn var' et (some e.toAddExpr), extended := []} + | some et, none => + {initial := Relation.rIsIn var' et none, extended := []} + | none, some (op, e) => + {initial := Relation.rCommon var' [(op, e.toAddExpr)], extended := []} + | none, none => + {initial := Relation.tt, extended := []} + | some _, some (_, _) => + -- entityType with a non-`in` operator (e.g., `==`) is not valid + {initial := Relation.ff, extended := []} + +public def VariableDef.toExpr (vd : VariableDef) : Expr := + vd.toAndExpr.toOrExpr.toExpr + +public def Cond.toExpr (c : Cond) : Expr := + match c.kind with + | .idWhen => c.body + | .idUnless => Expr.not c.body + | _ => Expr.tt + +-- The `effect` field is not considered in this translation +public def PolicyImpl.toExpr (p : PolicyImpl) : Expr := + let varExprs := List.map VariableDef.toExpr p.vars + let condExprs := List.map Cond.toExpr p.conds + Expr.foldAnd (varExprs ++ condExprs) + +public def Policy.toExpr : Policy → Expr + | policy p => PolicyImpl.toExpr p + +public def Policies.toExpr (ps : Policies) : Expr := + let exprs := List.map Policy.toExpr ps.ps + Expr.foldAnd exprs + +/- Authorizer -/ + +public def Policy.id : Policy → Spec.PolicyID + | .policy p => p.id + +public def satisfied (policy : Policy) (req : Spec.Request) (entities : Spec.Entities) : Bool := + policy.toExpr.evaluate req entities = .ok true + +-- To avoid returning an `Option Bool`, this function returns `false` +-- when the `effect` field of `policy` is not an effect +public def satisfiedWithEffect (effect : Spec.Effect) (policy : Policy) (req : Spec.Request) (entities : Spec.Entities) : Bool := + if satisfied policy req entities then + match policy with + | .policy p => match Ident.toEffect? p.effect with + | none => false + | some eff => eff = effect + else false + +public def satisfiedPolicies (effect : Spec.Effect) (policies : Policies) (req : Spec.Request) (entities : Spec.Entities) : Set Spec.PolicyID := + Set.make (List.filterMap + (fun p => if satisfiedWithEffect effect p req entities then some p.id else none) + policies.ps) + +public def hasError (policy : Policy) (req : Spec.Request) (entities : Spec.Entities) : Bool := + match policy with + | .policy p => + -- Strengthening: a policy with no AST translation (`toPolicy?` fails — due to + -- an invalid effect, an invalid scope triple, or a malformed/untranslatable + -- condition) is treated as an error. Under a successful translation + -- `toPolicy?` succeeds, so this guard is a no-op and agreement with the AST + -- (`policy_hasError_agrees`) is preserved. + if p.toPolicy?.isNone then true + else match policy.toExpr.evaluate req entities with + | .ok _ => false + | .error _ => true + +public def errorPolicies (policies : Policies) (req : Spec.Request) (entities : Spec.Entities) : Set Spec.PolicyID := + Set.make (List.filterMap + (fun p => if hasError p req entities then some p.id else none) + policies.ps) + + +public def isAuthorized (req : Spec.Request) (entities : Spec.Entities) (policies : Policies) : Spec.Response := + let forbids := satisfiedPolicies .forbid policies req entities + let permits := satisfiedPolicies .permit policies req entities + let erroringPolicies := errorPolicies policies req entities + if forbids.isEmpty && !permits.isEmpty + then {decision := .allow, determiningPolicies := permits, erroringPolicies} + else {decision := .deny, determiningPolicies := forbids, erroringPolicies} diff --git a/cedar-lean/Cedar/Frontend/Cst/Slice.lean b/cedar-lean/Cedar/Frontend/Cst/Slice.lean new file mode 100644 index 000000000..8b0536b47 --- /dev/null +++ b/cedar-lean/Cedar/Frontend/Cst/Slice.lean @@ -0,0 +1,80 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +module + +import Cedar.Spec +public import Cedar.Frontend.Cst.Syntax +import Cedar.Frontend.Cst.ToAst +public import Cedar.Slice.PolicySlice + +namespace Cedar.Frontend.Cst + +open Cedar.Spec +open Cedar.Frontend +open Cedar.Slice + +-- Returns true if a `VariableDef` is well-formed. +public def varBoundWF (vd : VariableDef) : Bool := + match vd.entityType, vd.ineq with + | none, some (.rEq, e) => (e.toEntityUID?).isSome + | none, some (.rIn, e) => (e.toEntityUID?).isSome + | some _, some (.rIn, e) => (e.toEntityUID?).isSome + | _, _ => true + +-- Extracts the principal and resource `VariableDef` from a CST Policy. +-- Returns none if the scopes are out of order or missing. +public def prVars? (policy : Policy) : Option (VariableDef × VariableDef) := + match policy with + | .policy p => match p.vars with + | [pr, act, res] => + match pr.var, act.var, res.var with + | .idPrincipal, .idAction, .idResource => + if varBoundWF pr && varBoundWF res then some (pr, res) else none + | _, _, _ => none + | _ => none + +-- Get the variable bound from a `VariableDef`. +public def varBound? (vd : VariableDef) : Option EntityUID := + match vd.entityType, vd.ineq with + | none, some (.rEq, e) => e.toEntityUID? -- principal == e + | none, some (.rIn, e) => e.toEntityUID? -- principal in e + | some _, some (.rIn, e) => e.toEntityUID? -- principal is _ in e + | _, _ => none + +-- Given a CST Policy and a proof term that the extraction of the +-- principal and resource `VariableDef` is successful, a `BoundAnalysis` +-- computes the `PolicyBound`. +public abbrev BoundAnalysis := (policy : Policy) → (prVars? policy).isSome → PolicyBound + +-- A bound-based slicing algorithm takes as input a bound analysis, request, +-- entities, policies, and a hypothesis that the principal and resourse +-- `VariableDef`s can be extracted from all policies, +-- and filters out the policies whose bound is not satisfied by the +-- request and entities. +public def BoundAnalysis.slice (ba : BoundAnalysis) (request : Request) (entities : Entities) + (policies : Cst.Policies) + (h : ∀ policy ∈ policies.ps, (prVars? policy).isSome) : Cst.Policies := + { ps := policies.ps.attach.filterMap (fun ⟨policy, hmem⟩ => + if satisfiedBound (ba policy (h policy hmem)) request entities then some policy else none) } + +-- Scope-based analysis extracts the bound from the policy. +public def scopeAnalysis (policy : Cst.Policy) (h : (prVars? policy).isSome) : PolicyBound := + let (pr, res) := (prVars? policy).get h + { principalBound := varBound? pr, + resourceBound := varBound? res } + +end Cedar.Frontend.Cst diff --git a/cedar-lean/Cedar/Frontend/Cst/Syntax.lean b/cedar-lean/Cedar/Frontend/Cst/Syntax.lean new file mode 100644 index 000000000..7155d3ca1 --- /dev/null +++ b/cedar-lean/Cedar/Frontend/Cst/Syntax.lean @@ -0,0 +1,342 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +module + +@[expose] public section + +namespace Cedar.Frontend.Cst + +-- The CST follows the Cedar grammar defined in grammar.lalrpop: +-- +-- Policies := {Policy} +-- Policy := {Annotation} Ident '(' [VariableDef {',' VariableDef}] ')' {Cond} ';' +-- Annotation := '@' Ident ['(' Str ')'] +-- VariableDef := Ident [':' Name] ['is' Add] [RelOp Expr] +-- Cond := Ident '{' Expr '}' +-- Expr := Or | 'if' Expr 'then' Expr 'else' Expr +-- Or := And {'||' And} +-- And := Relation {'&&' Relation} +-- Relation := Add {RelOp Add} | Add 'has' Add | Add 'like' Add | Add 'is' Add ['in' Add] +-- RelOp := '<' | '<=' | '>=' | '>' | '!=' | '==' | 'in' +-- Add := Mult {('+' | '-') Mult} +-- Mult := Unary {('*' | '/' | '%') Unary} +-- Unary := ['!' {'!'} | '-' {'-'}] Member +-- Member := Primary {MemAccess} +-- MemAccess := '.' Ident | '(' [Expr {',' Expr}] ')' | '[' Expr ']' +-- Primary := Literal | Ref | Name | Slot | '(' Expr ')' | '[' [Expr {',' Expr}] ']' | '{' [RecInit {',' RecInit}] '}' +-- Name := Ident {'::' Ident} +-- Ref := Name '::' (Str | '{' [RefInit {',' RefInit}] '}') +-- RefInit := Ident ':' Literal +-- RecInit := Expr ':' Expr +-- Literal := 'true' | 'false' | Number | Str +-- +-- Generally, the cst::* concrete syntax tree structures are represented without location +-- information in Lean. We also omit elements that are useful in Rust only for nice error reporting. + +/-- The list of Cedar keywords that cannot appear as plain identifiers. -/ +public def keywords : List String := + ["principal", "action", "resource", "context", "true", "false", + "permit", "forbid", "when", "unless", "in", "has", "like", "is", + "if", "then", "else"] + +--- "__cedar"] TODO: the __cedar identifier + +-- Identifiers of the Cedar language, including special ones +public inductive Ident where + -- rust cst::Ident::Principal + | idPrincipal + -- cst::Ident::Action + | idAction + -- cst::Ident::Resource + | idResource + -- cst::Ident::Context + | idContext + -- cst::Ident::True + | idTrue + -- cst::Ident::False + | idFalse + -- cst::Ident::Permit + | idPermit + -- cst::Ident::Forbid + | idForbid + -- cst::Ident::When + | idWhen + -- cst::Ident::Unless + | idUnless + -- cst::Ident::In + | idIn + -- cst::Ident::Has + | idHas + -- cst::Ident::Like + | idLike + -- cst::Ident::Is + | idIs + -- cst::Ident::If + | idIf + -- cst::Ident::Then + | idThen + -- cst::Ident::Else + | idElse + -- cst::Ident::Ident(SmoltStr) + | idIdent (s : String) (h : s ∉ keywords) + -- Note: the cst::Ident::Invalid(String) is not represented in Lean + +deriving instance DecidableEq, Repr for Ident + +/-- Convert an `Ident` back to its string representation. -/ +public def Ident.toString : Ident → String + | .idPrincipal => "principal" + | .idAction => "action" + | .idResource => "resource" + | .idContext => "context" + | .idTrue => "true" + | .idFalse => "false" + | .idPermit => "permit" + | .idForbid => "forbid" + | .idWhen => "when" + | .idUnless => "unless" + | .idIn => "in" + | .idHas => "has" + | .idLike => "like" + | .idIs => "is" + | .idIf => "if" + | .idThen => "then" + | .idElse => "else" + | .idIdent s _ => s + +-- This is a cst::Literal in Rust. +-- Should the type of n match the Rust implementation (i.e. UInt64)? +-- Why are true and false in both Ident and Literal? +public inductive Literal where + -- cst::Literal::True + | liTrue + -- cst::Literal::False + | liFalse + -- cst::Literal::Num(u64) + | liNum (n : UInt64) + -- cst::Literal::String(Node) + | liStr (s : String) + +-- This is a cst::RelOp +public inductive RelOp where + -- cst::RelOp::Less + | rLess + -- cst::RelOp::LessEq + | rLessEq + -- cst::RelOp::GreaterEq + | rGreaterEq + -- cst::RelOp::Greater + | rGreater + -- cst::RelOp::NotEq + | rNotEq + -- cst::RelOp::Eq + | rEq + -- cst::RelOp::In + | rIn + -- cst::InvalidSingleEq is not represented in Lean + +-- This is a cst::AddOp +public inductive AddOp where + -- cst::AddOp::Plus + | aPlus + -- cst::AddOp::Minus + | aMinus + +-- This is a cst::MultOp +public inductive MultOp where + -- cst::MultOp::Times + | mTimes + -- cst::MultOp::Divide + | mDivide + -- cst::MultOp::Mod + | mMod + +-- This matches the cst::NegOp where operators are counted with `u8` in Rust, `UInt8` in Lean +public inductive NegOp where + -- cst::NegOp::Bang(u8) + | nBang (n : UInt8) + -- cst::NegOp::Dash(u8) + | nDash (n : UInt8) + -- cst::NegOp::OverBand and cst::NegOp::OverDash are not represented in Lean, they are used + -- to return nice errors + +-- `inductive` is still used for single-constructor definitions that +-- are defined using enum in cst.rs so that it is easier to add +-- constructors in the future + +mutual + +-- This is a cst::Cond +-- Cond := Ident '{' Expr '}' +public structure Cond where + kind : Ident + body : Expr + +-- This is a cst::Str +-- There is no correspondence of Rust's `SmolStr` in LEAN +public inductive Str where + -- cst::Str::String(SmolStr) + | string (s : String) + -- Note: cst::Str::Invalid(SmolStr) is not represented in Lean + +-- This is a cst::Policies +public structure Policies where + ps : List Policy + +-- This is a cst::Policy +public inductive Policy where + -- cst::Policy::Policy(PolicyImpl) + | policy (p : PolicyImpl) + -- Note: cst::Policy::PolicyError (tolerant-ast feature) is not represented in Lean + +-- This is a cst::PolicyImpl +public structure PolicyImpl where + id : String + -- cst::PolicyImpl::annotations + annotations : List Annotation + effect : Ident + vars : List VariableDef + conds : List Cond + +-- This is a cst::Annotation +public structure Annotation where + name : Ident + value : Option Str + +-- This is a cst::VariableDef +-- `variable` is a LEAN keyword +public structure VariableDef where + -- cst::VariableDef::variable + var : Ident + -- cst::VariableDef::unused_type_name is not represented, only used for error reporting + -- cst::VariableDef::entity_type + entityType : Option AddExpr + -- cst::VariableDef::ineq + ineq : Option (RelOp × Expr) + + +-- This is a cst::Expr +public inductive Expr where + -- cst::Expr::Expr(ExprImpl) + | expr (e : ExprImpl) + -- Note: cst::Expr::ErrorExpr (tolerant-ast feature) is not represented in Lean + +-- This is a cst::ExprImpl +-- The `Box` data structure is dropped +public structure ExprImpl where + expr : ExprData + +-- This is a cst::ExprData +public inductive ExprData where + -- cst::ExprData::Or(Node) + | edOr (expr : OrExpr) + -- cst::ExprData::If(Node, Node, Node) + | edIf (i t e : Expr) -- `if` is a LEAN keyword + +-- This is a cst::Or +-- `Or` has already been declared in LEAN +public structure OrExpr where + initial : AndExpr + extended : List AndExpr + +-- This is a cst::And +public structure AndExpr where + initial : Relation + extended : List Relation + +-- This is a cst::Relation +public inductive Relation where + -- cst::Relation::Common { initial, extended } + | rCommon (initial : AddExpr) (extended : List (RelOp × AddExpr)) + -- cst::Relation::Has { target, field } + | rHas (target : AddExpr) (field : AddExpr) + -- cst::Relation::Like { target, pattern } + | rLike (target : AddExpr) (pattern : AddExpr) + -- cst::Relation::IsIn { target, entity_type, in_entity } + | rIsIn (target : AddExpr) (entityType : AddExpr) (inEntity : Option AddExpr) + +-- This is a cst::Add +public structure AddExpr where + initial : MultExpr + extended : List (AddOp × MultExpr) + +-- This is a cst::Mult +public structure MultExpr where + initial : Unary + extended : List (MultOp × Unary) + +-- This is a cst::Unary +public structure Unary where + op : Option NegOp + item : Member + +-- This is a cst::Member +public structure Member where + item : Primary + access : List MemAccess + +-- This is a cst::MemAccess +public inductive MemAccess where + -- cst::MemAccess::Field(Node) + | field (i : Ident) + -- cst::MemAccess::Call(Vec>) + | call (args : List Expr) + -- cst::MemAccess::Index(Node) + | index (e : Expr) + +-- This is a cst::Primary +public inductive Primary where + -- cst::Primary::Literal(Node) + | literal (l : Literal) + -- cst::Primary::Ref(Node) + | ref (r : Ref) + -- cst::Primary::Name(Node) + | name (n : Name) + -- cst::Primary::Slot(Node) + | slot (s : Str) + -- cst::Primary::Expr(Node) + | expr (e : Expr) + -- cst::Primary::EList(Vec>) + | eList (es : List Expr) + -- cst::Primary::RInits(Vec>) + | rInits (rs : List RecInit) + +-- This is a cst::RecInit(Node, Node) +public structure RecInit where + attr : Expr + value : Expr + +-- This is a cst::Name +public structure Name where + path : List Ident + name : Ident + +-- This is a cst::Ref +public inductive Ref where + -- cst::Ref::Uid { path, eid } + | uid (path : Name) (eid : Str) + -- cst::Ref::Ref { path, rinits } + | ref (path : Name) (rinits : List RefInit) + +-- This is a cst::RefInit(Node, Node) +public structure RefInit where + id : Ident + lit : Literal + +end + +end Cedar.Frontend.Cst diff --git a/cedar-lean/Cedar/Frontend/Cst/ToAst.lean b/cedar-lean/Cedar/Frontend/Cst/ToAst.lean new file mode 100644 index 000000000..c1ef012bf --- /dev/null +++ b/cedar-lean/Cedar/Frontend/Cst/ToAst.lean @@ -0,0 +1,778 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +module + +public import Cedar.Frontend.Cst.Syntax +public import Cedar.Frontend.Cst.Common +public import Cedar.Spec.Expr +public import Cedar.Spec.Policy +public import Cedar.Spec.Value + +public def String.toUnreservedId? (s : String) : Option String := + match s with + | "principal" | "action" | "resource" | "context" + | "true" | "false" | "permit" | "forbid" + | "when" | "unless" | "in" | "has" | "like" | "is" + | "if" | "then" | "else" => none + | _ => some s + +namespace Cedar.Frontend.Cst + +open Cedar + +public abbrev CExpr := Expr +public abbrev CName := Name +public abbrev AName := Spec.Name + +public inductive ExprOrSpecial where + -- Any expression except a variable, name, string literal, or bool literal + | expr (e : Spec.Expr) + -- Variables, which act as expressions or names + | var (v : Spec.Var) + -- Name that isn't an expr and couldn't be converted to var + | name (n : Spec.Name) + -- String literal, not yet unescaped + | strLit (lit : String) + -- A boolean literal + | boolLit (v : Bool) + +public def Ident.toUnreservedId? : Ident → Option String + | .idIdent s _ => if Unreserved? s then some s else none + | _ => none + +public def varToString : Spec.Var → String + | .principal => "principal" + | .action => "action" + | .resource => "resource" + | .context => "context" + +public inductive AstAccessor where + | field (id : Ident) + | call (args : List Spec.Expr) + | index (s : String) + +public def AstAccessor.toString : AstAccessor → String + | .field id => Ident.toString id + | .index s => s + | .call _ => "" + +public def ExprOrSpecial.toExpr? : ExprOrSpecial → Option Spec.Expr + | .expr e => some e + | .var v => some (.var v) + | .strLit s => do + let unescaped ← unescape? s + some (.lit (.string unescaped)) + | .boolLit b => some (.lit (.bool b)) + | .name _ => none + +public def Literal.toExprOrSpecial? (l : Literal) : Option ExprOrSpecial := + match l with + | .liTrue => some (.boolLit true) + | .liFalse => some (.boolLit false) + | .liNum n => do + let i ← Int64.ofInt? (n.toNat) + some (.expr (.lit (.int i))) + | .liStr s => some (.strLit s) + +public def Name.toVar? (n : Name) : Option Spec.Var := + if !n.path.isEmpty then none + else match n.name with + | .idPrincipal => some .principal + | .idAction => some .action + | .idResource => some .resource + | .idContext => some .context + | _ => none + +public def Ref.toExprOrSpecial? (r : Ref) : Option ExprOrSpecial := + match r with + | .uid path eid => do + let ty ← path.toAName? + match eid with + | .string s => do + let unescaped ← unescape? s + some (.expr (.lit (.entityUID {ty := ty, eid := unescaped}))) + | .ref _ _ => none + +public def oneArg? (args : List Spec.Expr) : Option Spec.Expr := + match args with + | e :: [] => some e + | _ => none + +public def toFunc? (n : Spec.Name) (args : List Spec.Expr) : Option Spec.Expr := do + if n.path.isEmpty && String.isFunctionName? n.id then + let xfn ← String.toExtFun? n.id + some (.call xfn args) + else none + +-- Remember to check that id is unreserved +public def Ident.toMeth? (id : Ident) (recv : Spec.Expr) (args : List Spec.Expr) : Option Spec.Expr := + match id with + | .idIdent s _ => do + let op ← String.toMethodOp? s + match op with + | .inl bop => let arg ← oneArg? args; some (.binaryApp bop recv arg) + | .inr uop => if args.isEmpty then some (.unaryApp uop recv) else none + | _ => none + + +public def memberAuxA : ExprOrSpecial → List AstAccessor → Option (ExprOrSpecial ⊕ (Spec.Expr × List AstAccessor)) + -- case 1: no accessors, return head immediately + | prim, [] => some (.inl prim) + + -- case 2: access on arbitrary expression, defer to phase B + | prim@(.expr _), asts@(_ :: _) + | prim@(.strLit _), asts@(_ :: _) + | prim@(.boolLit _), asts@(_ :: _) => do + let e ← prim.toExpr? + some (.inr (e, asts)) + + -- case 3: function call + | .name n, .call args :: rest => do + let e ← toFunc? n args + some (.inr (e, rest)) + + -- case 4: variable function call, error + | .var _, .call _ :: _ => none + + -- case 5: method call on name, error + | .name _, .field _ :: .call _ :: _ => none + + -- case 6: method call on a variable + | prim@(.var _), .field id :: .call args :: rest => do + let recv ← prim.toExpr? + let e ← id.toMeth? recv args + some (.inr (e, rest)) + + -- case 7: attribute access on a variable + | .var v, .field id :: rest => + let e := .getAttr (.var v) (Ident.toString id) + some (.inr (e, rest)) + + -- case 8: attribute access on a name, error + | .name _, .field _ :: _ => none + + -- case 9: index access on a name, error + | .name _, .index _ :: _ => none + + -- case 10: index access on a variable + | .var v, .index id :: rest => + let e := .getAttr (.var v) id + some (.inr (e, rest)) + +public def memberAuxB (head : Spec.Expr) : List AstAccessor → Option Spec.Expr + | .nil => some head + + -- function call on arbitrary expressions, error + | .call _ :: _ => none + + -- method call on arbitrary expressions + | .field id :: .call args :: rest => do + let head' ← id.toMeth? head args + memberAuxB head' rest + + -- field of arbitrary expressions + | .field id :: rest => do + memberAuxB (.getAttr head (Ident.toString id)) rest + + -- index into arbitrary expressions + | .index id :: rest => do + memberAuxB (.getAttr head id) rest + +public def memberAux (prim : ExprOrSpecial) (accs : List AstAccessor) : Option ExprOrSpecial := do + let reta ← memberAuxA prim accs + match reta with + | .inl eos => some eos + | .inr (e, rest) => + let ret ← memberAuxB e rest + some (.expr ret) + +public def bangN (e : Spec.Expr) (n : Nat) : Spec.Expr := + if n == 0 then e else bangN (Spec.Expr.unaryApp .not e) (n-1) + termination_by n + decreasing_by rename_i h; simp at h; omega + +public def dashN (e : Spec.Expr) (n : Nat) : Spec.Expr := + if n == 0 then e else dashN (Spec.Expr.unaryApp .neg e) (n-1) + termination_by n + decreasing_by rename_i h; simp at h; omega + +public def constructExprRel (op : RelOp) (e₁ e₂ : Spec.Expr) : Spec.Expr := + match op with + | .rLess => .binaryApp .less e₁ e₂ + | .rLessEq => .binaryApp .lessEq e₁ e₂ + | .rGreaterEq => .unaryApp .not (.binaryApp .less e₁ e₂) + | .rGreater => .unaryApp .not (.binaryApp .lessEq e₁ e₂) + | .rNotEq => .unaryApp .not (.binaryApp .eq e₁ e₂) + | .rEq => .binaryApp .eq e₁ e₂ + | .rIn => .binaryApp .mem e₁ e₂ + +public def constructAttrsAux? : List MemAccess → Option (List String) + | [] => some [] + | .field id :: rest => do + let head ← id.toUnreservedId? -- move toUnreserbvedId to CstCommon later + let tail ← constructAttrsAux? rest + head :: tail + | .index _ :: _ => none + | .call _ :: _ => none + +-- `first` should already be verified to be unreserved +-- Verify all elements in `rest` are unreserved +public def constructAttrs? (first : String) (rest : List MemAccess) : Option (List String) := do + let tail ← constructAttrsAux? rest + some (first :: tail) + +public def extendedHasAttr (target : Spec.Expr) (fields : List String) : Spec.Expr := + match fields with + | [] => target + | [f] => .hasAttr target f + | f :: rest => + .and (.hasAttr target f) (extendedHasAttr (.getAttr target f) rest) + +public def ExprOrSpecial.toValidAttr? (eos : ExprOrSpecial) : Option Spec.Attr := + match eos with + | .expr _ => none + | .var v => some (varToString v) + | .name n => if n.path.isEmpty then some (n.id) else none + | .strLit lit => unescape? lit + | .boolLit _ => none + +mutual + +public def rInitsToMap? (rs : List RecInit) : Option (List (Spec.Attr × Spec.Expr)) := + match rs with + | [] => some [] + | r :: rs => do + let attr_eos ← r.attr.toExprOrSpecial? + let maybe_attr ← attr_eos.toValidAttr? + let maybe_value ← r.value.toAExpr? + let rest ← rInitsToMap? rs + (maybe_attr, maybe_value) :: rest +termination_by (sizeOf rs, 0) +decreasing_by + all_goals simp_wf + all_goals first + | omega + | (cases r; simp only [RecInit.mk.sizeOf_spec]; omega) + +public def MemAccess.toAstAccessor? (m : MemAccess) : Option AstAccessor := + match m with + | .field i => match i with + | .idIdent s h => do + let _ ← Ident.toUnreservedString? (.idIdent s h) + some (.field (.idIdent s h)) + | _ => none + | .index e => do + let s ← Expr.toUnescapedStringLiteral? e + some (.index s) + | .call es => do + let xs ← Expr.toAExprs? es + some (.call xs) +termination_by (sizeOf m, 0) +decreasing_by + all_goals simp_wf + all_goals omega + +public def Primary.toExprOrSpecial? (e : Primary) : Option ExprOrSpecial := + match e with + | .literal l => l.toExprOrSpecial? + | .ref r => r.toExprOrSpecial? + | .name n => match n.toVar? with + | some v => some (.var v) + | none => do + let an ← n.toAName? + some (.name an) + | .expr e => do + let ae ← e.toAExpr? + some (.expr ae) + | .slot _ => none + | .eList es => do + let aes ← es.mapM₁ (fun ⟨x, _⟩ => x.toAExpr?) + some (.expr (.set aes)) + | .rInits r => do + let map ← rInitsToMap? r + some (.expr (.record map)) +termination_by (sizeOf e, 0) +decreasing_by + all_goals simp_wf + all_goals first | omega | (rename_i h; have := List.sizeOf_lt_of_mem h; omega) + +public def Primary.toAExpr? (e : Primary) : Option Spec.Expr := do + let ret ← e.toExprOrSpecial? + ret.toExpr? + +public def Member.toExprOrSpecial? (e : Member) : Option ExprOrSpecial := do + let prim ← e.item.toExprOrSpecial? + let accessors ← e.access.mapM (MemAccess.toAstAccessor?) + memberAux prim accessors +termination_by (sizeOf e, 0) +decreasing_by + all_goals simp_wf + all_goals + (obtain ⟨item, access⟩ := e + simp only [Member.mk.sizeOf_spec] + first + | omega + | (have h := List.sizeOf_lt_of_mem (by assumption) + dsimp only at h + omega)) + +public def Member.toAExpr? (e : Member) : Option Spec.Expr := do + let ret ← e.toExprOrSpecial? + ret.toExpr? + +public def Unary.toExprOrSpecial? (e : Unary) : Option ExprOrSpecial := + match e.op with + | none => e.item.toExprOrSpecial? + | some (.nDash 0) => e.item.toExprOrSpecial? + | some (.nBang n) => do + let eos ← e.item.toExprOrSpecial? + let expr ← eos.toExpr? + some (.expr (bangN expr (n.toNat))) + | some (.nDash n) => + match Member.toLit? e.item with + | some (.liNum x) => + let xNat := x.toNat + let minMagnitude := (Int64.MAX + 1).toNat + match compare xNat minMagnitude with + | .eq => some (.expr (dashN (Spec.Expr.lit (.int (Int64.MIN).toInt64)) (n-1).toNat)) + | .lt => + match Int64.ofInt? (Int.ofNat xNat) with + | some y => some (.expr (dashN (Spec.Expr.lit (.int (-y))) (n-1).toNat)) + | none => none + | .gt => none + | _ => do + let eos ← e.item.toExprOrSpecial? + let expr ← eos.toExpr? + some (ExprOrSpecial.expr (dashN expr n.toNat)) +termination_by (sizeOf e, 0) +decreasing_by + all_goals (cases e; simp only [Unary.mk.sizeOf_spec]; omega) + +public def Unary.toAExpr? (e : Unary) : Option Spec.Expr := do + let ret ← e.toExprOrSpecial? + ret.toExpr? +termination_by (sizeOf e, 1) + +public def MultExpr.foldExtended (acc : Spec.Expr) (xs : List (MultOp × Unary)) : Option Spec.Expr := + match xs with + | [] => some acc + | (op, u) :: rest => do + let aval ← u.toAExpr? + match op with + | .mTimes => MultExpr.foldExtended (Spec.Expr.binaryApp .mul acc aval) rest + | _ => none +termination_by (sizeOf xs, 0) + +public def MultExpr.toExprOrSpecial? (e : MultExpr) : Option ExprOrSpecial := + match e.extended with + | [] => e.initial.toExprOrSpecial? + | _ => do + let first ← e.initial.toAExpr? + let result ← MultExpr.foldExtended first e.extended + some (.expr result) +termination_by (sizeOf e, 0) +decreasing_by + all_goals (cases e; simp only [MultExpr.mk.sizeOf_spec]; omega) + +public def MultExpr.toAExpr? (e : MultExpr) : Option Spec.Expr := do + let ret ← e.toExprOrSpecial? + ret.toExpr? +termination_by (sizeOf e, 1) + +public def AddExpr.foldExtended (acc : Spec.Expr) (xs : List (AddOp × MultExpr)) : Option Spec.Expr := + match xs with + | [] => some acc + | (op, m) :: rest => do + let aval ← m.toAExpr? + match op with + | .aPlus => AddExpr.foldExtended (Spec.Expr.binaryApp .add acc aval) rest + | .aMinus => AddExpr.foldExtended (Spec.Expr.binaryApp .sub acc aval) rest +termination_by (sizeOf xs, 0) + +public def AddExpr.toExprOrSpecial? (e : AddExpr) : Option ExprOrSpecial := + match e.extended with + | [] => e.initial.toExprOrSpecial? + | _ => do + let first ← e.initial.toAExpr? + let result ← AddExpr.foldExtended first e.extended + some (.expr result) +termination_by (sizeOf e, 0) +decreasing_by + all_goals (cases e; simp only [AddExpr.mk.sizeOf_spec]; omega) + +public def AddExpr.toAExpr? (e : AddExpr) : Option Spec.Expr := do + let ret ← e.toExprOrSpecial? + ret.toExpr? +termination_by (sizeOf e, 1) + +public def AddExpr.toEntityType? (e : AddExpr) : Option Spec.EntityType := do + let eos ← e.toExprOrSpecial? + match eos with + | .name n => some n + | .var _ => none -- in Rust unqualified name + | _ => none +termination_by (sizeOf e, 1) + + +-- In Rust, `to_has_rhs` has the output type `Option (String ⊕ UnreservedId)`. +-- `UnservedId` is essentially a string, but passed the check that it's not +-- "__cedar". In this implementation, we keep the output type `String` +-- and return a `none` if it is reserved. +public def AddExpr.toHasRhs? (e : AddExpr) : Option (String ⊕ List String) := do + if (!e.extended.isEmpty) || (!e.initial.extended.isEmpty) || (!e.initial.initial.op.isNone) then none else + let member := e.initial.initial.item + match member.item with + | .literal _ | .name _ => + let item ← member.item.toExprOrSpecial? + match item, member.access with + | .strLit lit, [] => (unescape? lit).map .inl + | .var v, rest => (constructAttrs? (varToString v) rest).map .inr + | .name n, rest => if !n.path.isEmpty then none else + let first ← n.id.toUnreservedId? + (constructAttrs? first rest).map .inr + | _, _ => none + | _ => none +termination_by (sizeOf e, 2) +decreasing_by + all_goals + have h1 : sizeOf e.initial.initial.item.item < sizeOf e := by + rcases e with ⟨⟨⟨_, m⟩, _⟩, _⟩ + rcases m with ⟨_, _⟩ + simp only [AddExpr.mk.sizeOf_spec, MultExpr.mk.sizeOf_spec, + Unary.mk.sizeOf_spec, Member.mk.sizeOf_spec] + omega + omega + +public def AddExpr.toPattern? (e : AddExpr) : Option Spec.Pattern := do + let eos ← e.toExprOrSpecial? + match eos with + | .strLit lit => toPattern? lit + | _ => none +termination_by (sizeOf e, 2) + +public def Relation.toExprOrSpecial? : Relation → Option ExprOrSpecial + | .rCommon initial extended => + if extended.length > 1 then none else do + let first ← initial.toExprOrSpecial? + match extended with + | [] => some first + | (op, x) :: _ => + let first ← first.toExpr? + let second ← x.toAExpr? + some (.expr (constructExprRel op first second)) + | .rHas target field => do + let maybe_target ← target.toAExpr? + let maybe_fields ← field.toHasRhs? + match maybe_fields with + | .inl f => some (.expr (.hasAttr maybe_target f)) + | .inr fs => some (.expr (extendedHasAttr maybe_target fs)) + | .rLike target pattern => do + let maybe_target ← target.toAExpr? + let maybe_pattern ← pattern.toPattern? + some (.expr (.unaryApp (.like maybe_pattern) maybe_target)) + | .rIsIn target ety inEntity => do + let maybe_target ← target.toAExpr? + let maybe_entity_type ← ety.toEntityType? + let isExpr := Spec.Expr.unaryApp (.is maybe_entity_type) maybe_target + match inEntity with + | some ie => do + let maybe_in ← ie.toAExpr? + some (.expr (.and isExpr (.binaryApp .mem maybe_target maybe_in))) + | none => some (.expr isExpr) +termination_by e => (sizeOf e, 0) + +public def Relation.toAExpr? (e : Relation) : Option Spec.Expr := do + let ret ← e.toExprOrSpecial? + ret.toExpr? +termination_by (sizeOf e, 1) + +public def AndExpr.foldExtended (acc : Spec.Expr) (xs : List Relation) : Option Spec.Expr := + match xs with + | [] => some acc + | rel :: rest => do + let aval ← rel.toAExpr? + AndExpr.foldExtended (Spec.Expr.and acc aval) rest +termination_by (sizeOf xs, 0) + +public def AndExpr.toExprOrSpecial? (e : AndExpr) : Option ExprOrSpecial := + match e.extended with + | [] => e.initial.toExprOrSpecial? + | _ => do + let first ← e.initial.toAExpr? + let result ← AndExpr.foldExtended first e.extended + some (.expr result) +termination_by (sizeOf e, 0) +decreasing_by + all_goals (cases e; simp only [AndExpr.mk.sizeOf_spec]; omega) + +public def AndExpr.toAExpr? (e : AndExpr) : Option Spec.Expr := do + let ret ← e.toExprOrSpecial? + ret.toExpr? +termination_by (sizeOf e, 1) + +public def OrExpr.foldExtended (acc : Spec.Expr) (xs : List AndExpr) : Option Spec.Expr := + match xs with + | [] => some acc + | ande :: rest => do + let aval ← ande.toAExpr? + OrExpr.foldExtended (Spec.Expr.or acc aval) rest +termination_by (sizeOf xs, 0) + +public def OrExpr.toExprOrSpecial? (e : OrExpr) : Option ExprOrSpecial := + match e.extended with + | [] => e.initial.toExprOrSpecial? + | _ => do + let first ← e.initial.toAExpr? + let result ← OrExpr.foldExtended first e.extended + some (.expr result) +termination_by (sizeOf e, 0) +decreasing_by + all_goals (cases e; simp only [OrExpr.mk.sizeOf_spec]; omega) + +public def OrExpr.toAExpr? (e : OrExpr) : Option Spec.Expr := do + let ret ← e.toExprOrSpecial? + ret.toExpr? + +public def ExprData.toExprOrSpecial? : ExprData → Option ExprOrSpecial + | .edOr ore => ore.toExprOrSpecial? + | .edIf i t e => do + let maybe_guard ← i.toAExpr? + let maybe_then ← t.toAExpr? + let maybe_else ← e.toAExpr? + some (.expr (.ite maybe_guard maybe_then maybe_else)) +termination_by e => (sizeOf e, 0) + +public def ExprData.toAExpr? (e : ExprData) : Option Spec.Expr := do + let ret ← e.toExprOrSpecial? + ret.toExpr? + +public def ExprImpl.toExprOrSpecial? (e : ExprImpl) : Option ExprOrSpecial := + e.expr.toExprOrSpecial? +termination_by (sizeOf e, 0) +decreasing_by + all_goals (cases e; simp only [ExprImpl.mk.sizeOf_spec]; omega) + +public def ExprImpl.toAExpr? (e : ExprImpl) : Option Spec.Expr := do + let ret ← e.toExprOrSpecial? + ret.toExpr? + +public def Expr.toExprOrSpecial? : CExpr → Option ExprOrSpecial + | .expr impl => impl.toExprOrSpecial? +termination_by e => (sizeOf e, 0) + +public def Expr.toAExpr? (e : Expr) : Option Spec.Expr := do + let ret ← e.toExprOrSpecial? + ret.toExpr? +termination_by (sizeOf e, 1) + +public def Expr.toAExprs? : List CExpr → Option (List Spec.Expr) + | [] => some [] + | e :: es => do + let a ← e.toAExpr? + let as ← Expr.toAExprs? es + some (a :: as) +termination_by es => (sizeOf es, 0) +decreasing_by + all_goals simp_wf + all_goals omega + +end + +public def Ident.toConditionKind? : Ident → Option Spec.ConditionKind + | .idWhen => some .when + | .idUnless => some .unless + | _ => none + +public def Cond.toCondition? (cond : Cond) : Option Spec.Condition := do + let kind ← cond.kind.toConditionKind? + let body ← cond.body.toAExpr? + some {kind := kind, body := body} + +public def toConditions? (conds : List Cond) : Option Spec.Conditions := do + conds.mapM (·.toCondition?) + +private def Ident.toVar? : Ident → Option Spec.Var + | .idPrincipal => some .principal + | .idAction => some .action + | .idResource => some .resource + | .idContext => some .context + | _ => none + +-- Helper lemma: a `Primary` reachable through the AddExpr→Primary chain +-- has strictly smaller `sizeOf` than the surrounding `OrExpr`. +public theorem sizeOf_addExpr_primary_lt_orExpr (o : OrExpr) (ae : AddExpr) (ext : List (RelOp × AddExpr)) + (h : o.initial.initial = .rCommon ae ext) : + sizeOf ae.initial.initial.item.item < sizeOf o := by + -- ae.initial : MultExpr ⟨Unary, List _⟩ + -- ae.initial.initial : Unary ⟨Option NegOp, Member⟩ + -- ae.initial.initial.item : Member ⟨Primary, List MemAccess⟩ + -- ae.initial.initial.item.item : Primary + obtain ⟨ae_mult, ae_ext⟩ := ae + obtain ⟨ae_unary, ae_mult_ext⟩ := ae_mult + obtain ⟨ae_op, ae_member⟩ := ae_unary + obtain ⟨ae_prim, ae_access⟩ := ae_member + obtain ⟨o_and, o_ext⟩ := o + obtain ⟨o_rel, o_and_ext⟩ := o_and + simp_all + omega + +mutual + +public def Primary.toMultipleEntityUID? (p : Primary) : Option (Spec.EntityUID ⊕ List Spec.EntityUID) := + match p with + | .literal _ | .name _ | .slot _ => none + | .ref r => match r with + | .uid path (.string s) => do + let maybe_path ← path.toAName? + let maybe_eid ← unescape? s + some (.inl {ty := maybe_path, eid := maybe_eid}) + | .ref _ _ => none + | .expr e => e.toMultipleEntityUID? + | .eList es => do + let uids ← es.attach.mapM (fun ⟨x, hmem⟩ => + have : sizeOf x < sizeOf es := List.sizeOf_lt_of_mem hmem + match x.toMultipleEntityUID? with + | some (.inl eref) => some eref + | _ => none) + some (.inr uids) + | .rInits _ => none +termination_by (sizeOf p, 0) +decreasing_by + all_goals (simp_wf; omega) + +public def Expr.toMultipleEntityUID? (e : Expr) : Option (Spec.EntityUID ⊕ List Spec.EntityUID) := + match e with + | .expr ⟨.edIf _ _ _⟩ => none + | .expr ⟨.edOr o⟩ => + if !o.extended.isEmpty || !o.initial.extended.isEmpty then none + else + match h : o.initial.initial with + | .rHas _ _ | .rLike _ _ => none + | .rCommon ae ext => + if !ext.isEmpty || !ae.extended.isEmpty || !ae.initial.extended.isEmpty + || !ae.initial.initial.op.isNone || !ae.initial.initial.item.access.isEmpty then none + else + have : sizeOf ae.initial.initial.item.item < sizeOf o := + sizeOf_addExpr_primary_lt_orExpr o ae ext h + ae.initial.initial.item.item.toMultipleEntityUID? + | .rIsIn _ _ _ => none +termination_by (sizeOf e, 1) +decreasing_by + all_goals (simp_wf; omega) + +end + +public def Expr.toEntityUID? (e : Expr) : Option Spec.EntityUID := do + let erefs ← e.toMultipleEntityUID? + match erefs with + | .inl eref => some eref + | .inr _ => none + +public def Expr.toEntityUIDs? (e : Expr) : Option (List Spec.EntityUID) := do + let erefs ← e.toMultipleEntityUID? + match erefs with + | .inl eref => some [eref] + | .inr erefs => some erefs + +-- To be used when translating a `VariableDef` to a `PrincipalScope` or +-- a `ResourceScope` +public def VariableDef.toPRScope? (v : VariableDef) : Option Spec.Scope:= + match v.ineq, v.entityType with + | none, none => some .any + | some (op, e), _ => match op, v.entityType with + | .rEq, none => do + let eref ← e.toEntityUID? + some (.eq eref) + | .rEq, some _ => none + | .rIn, none => do + let eref ← e.toEntityUID? + some (.mem eref) + | .rIn, some t => do + let eref ← e.toEntityUID? + let ety ← t.toEntityType? + some (.isMem ety eref) + | _, _ => none + | none, some t => do + let ety ← t.toEntityType? + some (.is ety) + +public def VariableDef.toPrincipalScope? (v : VariableDef) : Option Spec.PrincipalScope := + match v.var with + | .idPrincipal => do + let scope ← v.toPRScope? + some (.principalScope scope) + | _ => none + +public def VariableDef.toResourceScope? (v : VariableDef) : Option Spec.ResourceScope := + match v.var with + | .idResource => do + let scope ← v.toPRScope? + some (.resourceScope scope) + | _ => none + +public def isAction? (uid : Spec.EntityUID) : Bool := + uid.ty.id == "Action" + +-- Need to check `contains_only_action_types` before using the `ActionScope` output +public def VariableDef.toActionScopeAux? (v : VariableDef) : Option Spec.ActionScope := + match v.var with + | .idAction => if v.entityType.isSome then none else + match v.ineq with + | none => some (.actionScope (.any)) + | some (op, e) => match op with + | .rEq => do + let eref ← e.toEntityUID? + some (.actionScope (.eq eref)) + | .rIn => do + let erefs ← e.toEntityUIDs? + some (.actionInAny erefs) + | _ => none + | _ => none + +public def containsOnlyActionTypes? (as : Spec.ActionScope) : Bool := + match as with + | .actionScope scope => match scope with + | .any => true + | .eq eref => isAction? eref + | .mem eref => isAction? eref + | _ => false + | .actionInAny erefs => erefs.all (isAction? ·) + +public def VariableDef.toActionScope? (v : VariableDef) : Option Spec.ActionScope := do + let as ← v.toActionScopeAux? + if containsOnlyActionTypes? as then some as else none + +public def extractScope? (vars : List VariableDef) : Option (Spec.PrincipalScope × Spec.ActionScope × Spec.ResourceScope) := do + match vars with + | a :: b :: c :: .nil => do + let ps ← a.toPrincipalScope? + let as ← b.toActionScope? + let rs ← c.toResourceScope? + some (ps, as, rs) + | _ => none + +public def PolicyImpl.toPolicy? (p : PolicyImpl) : Option Spec.Policy := do + let effect ← Ident.toEffect? p.effect + let (ps, as, rs) ← extractScope? p.vars + let conds ← toConditions? p.conds + some {id := p.id, effect := effect, principalScope := ps, actionScope := as, resourceScope := rs, condition := conds} + +public def Policy.toPolicy? : Policy → Option Spec.Policy + | .policy p => p.toPolicy? + +public def Policies.toPolicies? (ps : Policies) : Option Spec.Policies := do + ps.ps.mapM Policy.toPolicy? diff --git a/cedar-lean/Cedar/Frontend/CstErrorCollector.lean b/cedar-lean/Cedar/Frontend/CstErrorCollector.lean new file mode 100644 index 000000000..cb2ba9bba --- /dev/null +++ b/cedar-lean/Cedar/Frontend/CstErrorCollector.lean @@ -0,0 +1,29 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +module + +public import Cedar.Frontend.Cst +public import Cedar.Spec.Entities +public import Cedar.Spec.Request +public import Cedar.Spec.Response +public import Cedar.Spec.Value +public import Cedar.Spec.Evaluator +public import Cedar.Frontend.Cst.ToAst + +namespace Cedar.Spec.Cst + +open Cedar.Data diff --git a/cedar-lean/Cedar/Frontend/Parser.lean b/cedar-lean/Cedar/Frontend/Parser.lean new file mode 100644 index 000000000..00cd58f58 --- /dev/null +++ b/cedar-lean/Cedar/Frontend/Parser.lean @@ -0,0 +1,574 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +module + +public import Cedar.Frontend.Cst +public import Cedar.Frontend.Cst.Syntax +public import Std.Internal.Parsec.String + +/-! This file defines a parser from Cedar policy text to the CST. -/ + +@[expose] public section + +---- String conversion utilities --- + +-- Parsing hex numbers `\xHH` and unicode codepoints `\u{...}` is done with the +-- functions `Char.asHexNat` and `String.asHexNat`. We prove that the latter roundtrips +-- with `Nat.toHexString` implemented here, for natural numbers ≤ 0xFFFFFF. + + +/-- Parses a character into a `Nat` number, assuming the character is the hex reprsentation of +that natural number. -/ +def Char.asHexNat (c : Char) : Except String Nat := + if '0' ≤ c && c ≤ '9' then .ok (c.toNat - '0'.toNat) + else if 'a' ≤ c && c ≤ 'f' then .ok (c.toNat - 'a'.toNat + 10) + else if 'A' ≤ c && c ≤ 'F' then .ok (c.toNat - 'A'.toNat + 10) + else .error s!"invalid hex digit: '{c}'" + +/-- Parses a string into a `Nat` number, assuming the string is the hex representation of that + natural number. -/ +def String.asHexNat (s : String) : Except String Nat := + if s.isEmpty then .error "empty hex string" + else if s.length > 6 then .error "hex string too long" + else s.toList.foldl (fun acc c => do + let n ← acc + let d ← c.asHexNat + .ok (n * 16 + d)) (.ok 0) + +/-- Simple recursive hex digit list with explicit termination. -/ +def Nat.toHexChars (n : Nat) : List Char := + if n == 0 then ['0'] else go n [] +where + go : Nat → List Char → List Char + | 0, acc => acc + | n + 1, acc => + let val := n + 1 + let d := val % 16 + let r := val / 16 + go r (Nat.digitChar d :: acc) + termination_by n => n + +def Nat.toHexString (n : Nat) : String := + String.ofList (Nat.toHexChars n) + +namespace Except +open Std.Internal.Parsec String +def liftParser (r: Except String α) : Parser α := + match r with + |.ok a => pure a + |.error s => fail s +end Except + +namespace Cedar.Frontend.Cst.Parser + +open Std.Internal.Parsec String + +----- Utilities ----- + +/-- Skip whitespace and `//` line comments -/ +partial def wsAndComments : Parser Unit := do + ws + if (← (attempt (skipString "//") *> pure true) <|> pure false) then + skipLine + wsAndComments +where + skipLine : Parser Unit := do + repeat + match ← peek? with + | none => return () + | some '\n' => skip ; return () + | some _ => skip + +/-- Run a parser, then consume trailing whitespace/comments -/ +@[inline] def tok {α : Type} (p : Parser α) : Parser α := do + let a ← p ; wsAndComments ; return a + +/-- Parse and skip a specific character, then whitespace -/ +@[inline] def char' (c : Char) : Parser Unit := tok (skipChar c) + +/-- Parse and skip a specific string, then whitespace -/ +@[inline] def str' (s : String) : Parser Unit := tok (skipString s) + +----- Identifiers ----- + +def isIdentStart (c : Char) : Bool := + c.isAlpha || c == '_' + +def isIdentCont (c : Char) : Bool := + c.isAlphanum || c == '_' + +/-- Parse a raw identifier string -/ +def rawIdent : Parser String := tok do + let c ← satisfy isIdentStart + let rest ← manyChars (satisfy isIdentCont) + return String.ofList (c :: rest.toList) + +/-- Classify a raw identifier string into an `Ident`. + Uses dependent `if` rather than `match` because Lean's pattern matching on `String` + does not provide discrimination hypotheses in the catch-all case, which are needed + to prove that the keyword branch is exhaustive and to supply the `s ∉ keywords` proof. -/ +public def classifyIdent (s : String) : Ident := + if h : s ∈ keywords then + if _ : s = "principal" then .idPrincipal + else if _ : s = "action" then .idAction + else if _ : s = "resource" then .idResource + else if _ : s = "context" then .idContext + else if _ : s = "true" then .idTrue + else if _ : s = "false" then .idFalse + else if _ : s = "permit" then .idPermit + else if _ : s = "forbid" then .idForbid + else if _ : s = "when" then .idWhen + else if _ : s = "unless" then .idUnless + else if _ : s = "in" then .idIn + else if _ : s = "has" then .idHas + else if _ : s = "like" then .idLike + else if _ : s = "is" then .idIs + else if _ : s = "if" then .idIf + else if _ : s = "then" then .idThen + else if _ : s = "else" then .idElse + else -- only remaining keyword is "__cedar" + have : s = "__cedar" := by simp_all [keywords] + .idElse -- placeholder: __cedar never appears as a standalone identifier + else + .idIdent s h + +/-- Parse an identifier -/ +public def parseIdent : Parser Ident := do + return classifyIdent (← rawIdent) + +/-- Expect a specific keyword -/ +public def keyword (s : String) : Parser Unit := do + let i ← rawIdent + if i != s then fail s!"expected '{s}', got '{i}'" + +/-- Try to consume a keyword; return true if successful -/ +public def tryKeyword (s : String) : Parser Bool := + (attempt (keyword s) *> pure true) <|> pure false + + +----- Literals ----- + +/-- Parse a natural number -/ +public def parseNat : Parser UInt64 := tok do + let s ← many1Chars (satisfy Char.isDigit) + match s.toNat? with + | some n => return n.toUInt64 + | none => fail s!"invalid number: {s}" + +/-- + Parse a string literal (double-quoted, with escape sequences). + The STR element uses the same string literal syntax as Rust string literals, supporting the + following escape sequences: \", \\, \n, \r, \t, \0, \xHH (2-digit ASCII hex escape), + and \u{...} (1–6 digit Unicode escape). +-/ +public partial def stringLit : Parser String := do + skipChar '"' + stringLitBody "" +where + stringLitBody (s : String) : Parser String := do + match ← any with + | '"' => + wsAndComments + return s + | '\\' => + let c ← any + let s ← match c with + | 'n' => pure (s.push '\n') + | 'r' => pure (s.push '\r') + | 't' => pure (s.push '\t') + | '\\' => pure (s.push '\\') + | '"' => pure (s.push '"') + | '\'' => pure (s.push '\'') + | '0' => pure (s.push '\x00') + -- 2-digit ASCII hex escape: `\xHH` where H is a hex digit is an escape for a natural number + | 'x' => do + let h ← hexDigit + let l ← hexDigit + let n := h * 16 + l + pure (s.push (Char.ofNat n)) + -- 1-6 digit unicode escape: `\u{...}` + | 'u' => do + skipChar '{' + -- get all digits until next } + let n ← do (← manyChars (satisfy fun c => c != '}')).asHexNat.liftParser + skipChar '}' + pure (s.push (Char.ofNat n)) + | c => pure (s.push '\\' |>.push c) + stringLitBody s + | c => stringLitBody (s.push c) + hexDigit : Parser Nat := do (← any).asHexNat.liftParser + +/-- Parse a literal -/ +def parseLiteral : Parser Literal := + (Literal.liStr <$> stringLit) <|> + (Literal.liNum <$> parseNat) <|> + (attempt (keyword "true") *> pure .liTrue) <|> + (attempt (keyword "false") *> pure .liFalse) + +----- RelOp parsing ----- + +def tryRelOp : Parser (Option RelOp) := + (attempt (str' "<=" *> pure (some RelOp.rLessEq))) <|> + (attempt (str' ">=" *> pure (some RelOp.rGreaterEq))) <|> + (attempt (str' "!=" *> pure (some RelOp.rNotEq))) <|> + (attempt (str' "==" *> pure (some RelOp.rEq))) <|> + (attempt (do + skipChar '<' + notFollowedBy (satisfy (· == '=')) + wsAndComments + pure (some RelOp.rLess))) <|> + (attempt (do + skipChar '>' + notFollowedBy (satisfy (· == '=')) + wsAndComments + pure (some RelOp.rGreater))) <|> + (attempt (keyword "in" *> pure (some RelOp.rIn))) <|> + pure none + +----- Expression parsing (mutually recursive) ----- + +mutual + +partial def expr : Parser Expr := do + let ite ← (attempt do + keyword "if" + let cond ← expr + keyword "then" + let thenE ← expr + keyword "else" + let elseE ← expr + return Expr.expr { expr := .edIf cond thenE elseE } + ) <|> do + let o ← orExpr + return Expr.expr { expr := .edOr o } + return ite + +partial def orExpr : Parser OrExpr := do + let initial ← andExpr + let mut extended : List AndExpr := [] + while (← (attempt (str' "||") *> pure true) <|> pure false) do + extended := extended ++ [← andExpr] + return { initial, extended } + +partial def andExpr : Parser AndExpr := do + let initial ← relation + let mut extended : List Relation := [] + while (← (attempt (str' "&&") *> pure true) <|> pure false) do + extended := extended ++ [← relation] + return { initial, extended } + +partial def relation : Parser Relation := do + let target ← addExpr + (attempt (do + keyword "has" + let field ← addExpr + return Relation.rHas target field + )) <|> (attempt (do + keyword "like" + let pattern ← addExpr + return Relation.rLike target pattern + )) <|> (attempt (do + keyword "is" + let entityType ← addExpr + let inEntity ← if (← tryKeyword "in") then some <$> addExpr else pure none + return Relation.rIsIn target entityType inEntity + )) <|> do + let mut items : List (RelOp × AddExpr) := [] + while true do + match ← tryRelOp with + | some op => + let rhs ← addExpr + items := items ++ [(op, rhs)] + | none => break + return Relation.rCommon target items + +partial def addExpr : Parser AddExpr := do + let initial ← multExpr + let mut extended : List (AddOp × MultExpr) := [] + while true do + let op ← (attempt (char' '+' *> pure (some AddOp.aPlus))) <|> + (attempt (char' '-' *> pure (some AddOp.aMinus))) <|> + pure none + match op with + | some o => + let rhs ← multExpr + extended := extended ++ [(o, rhs)] + | none => break + return { initial, extended } + +partial def multExpr : Parser MultExpr := do + let initial ← unary + let mut extended : List (MultOp × Unary) := [] + while true do + let op ← (attempt (char' '*' *> pure (some MultOp.mTimes))) <|> + (attempt (char' '/' *> pure (some MultOp.mDivide))) <|> + (attempt (char' '%' *> pure (some MultOp.mMod))) <|> + pure none + match op with + | some o => + let rhs ← unary + extended := extended ++ [(o, rhs)] + | none => break + return { initial, extended } + +partial def unary : Parser Unary := do + match ← peek? with + | some '!' => + let n ← countChar '!' + let m ← member + return { op := some (.nBang n), item := m } + | some '-' => + let n ← countChar '-' + let m ← member + return { op := some (.nDash n), item := m } + | _ => + let m ← member + return { op := none, item := m } +where + countChar (c : Char) : Parser UInt8 := do + let mut n : UInt8 := 0 + while (← (attempt (skipChar c *> pure true)) <|> pure false) do + n := n + 1 + wsAndComments + return n + +partial def member : Parser Member := do + let item ← primary + let mut access : List MemAccess := [] + while true do + let acc ← + (attempt (do + char' '.' + let i ← parseIdent + return some (MemAccess.field i))) <|> + (attempt (do + char' '(' + let args ← exprListUntil ')' + char' ')' + return some (MemAccess.call args))) <|> + (attempt (do + char' '[' + let e ← expr + char' ']' + return some (MemAccess.index e))) <|> + pure none + match acc with + | some a => access := access ++ [a] + | none => break + return { item, access } + +partial def primary : Parser Primary := do + match ← peek? with + | some '"' => return .literal (.liStr (← stringLit)) + | some '?' => + skip + let s ← rawIdent + return .slot (.string s) + | some '(' => + char' '(' + let e ← expr + char' ')' + return .expr e + | some '[' => + char' '[' + let es ← exprListUntil ']' + char' ']' + return .eList es + | some '{' => + char' '{' + let rs ← recInitsUntil '}' + char' '}' + return .rInits rs + | some c => + if c.isDigit then + return .literal (.liNum (← parseNat)) + else if isIdentStart c then + refOrNameOrLit + else + fail s!"unexpected character '{c}'" + | none => fail "unexpected end of input" +where + refOrNameOrLit : Parser Primary := + (attempt do + let n ← parseName + str' "::" + match ← peek? with + | some '"' => + let s ← stringLit + return Primary.ref (.uid n (.string s)) + | some '{' => + char' '{' + let inits ← refInitsUntil '}' + char' '}' + return Primary.ref (.ref n inits) + | _ => fail "expected string or '{' after '::'") <|> + (do + let n ← parseName + match n.path, n.name with + | [], .idTrue => return .literal .liTrue + | [], .idFalse => return .literal .liFalse + | _, _ => return .name n) + parseName : Parser Name := do + let first ← parseIdent + let mut path : List Ident := [] + let mut last := first + -- Consume '::' Ident, but not '::' followed by '"' or '{' + while (← (attempt (do + skipString "::" + let c ← peek! + if c == '"' || c == '{' then fail "ref separator" + if !(isIdentStart c) then fail "not ident" + pure true)) <|> pure false) do + path := path ++ [last] + last ← parseIdent + return { path, name := last } + refInitsUntil (closing : Char) : Parser (List RefInit) := do + match ← peek? with + | some c => if c == closing then return [] else refInitList + | none => return [] + refInitList : Parser (List RefInit) := do + let first ← parseRefInit + let mut items := [first] + while (← (attempt (char' ',') *> pure true) <|> pure false) do + items := items ++ [← parseRefInit] + return items + parseRefInit : Parser RefInit := do + let id ← parseIdent + char' ':' + let lit ← parseLiteral + return { id, lit } + recInitsUntil (closing : Char) : Parser (List RecInit) := do + match ← peek? with + | some c => if c == closing then return [] else recInitList + | none => return [] + recInitList : Parser (List RecInit) := do + let first ← parseRecInit + let mut items := [first] + while (← (attempt (char' ',') *> pure true) <|> pure false) do + items := items ++ [← parseRecInit] + return items + parseRecInit : Parser RecInit := do + let attr ← expr + char' ':' + let value ← expr + return { attr, value } + +/-- Parse a comma-separated list of expressions until a closing char -/ +partial def exprListUntil (closing : Char) : Parser (List Expr) := do + match ← peek? with + | some c => if c == closing then return [] else exprList1 + | none => return [] +where + exprList1 : Parser (List Expr) := do + let first ← expr + let mut items := [first] + while (← (attempt (char' ',') *> pure true) <|> pure false) do + items := items ++ [← expr] + return items + +end + +----- Policy-level parsing ----- + +/-- Parse a Cond (e.g., `when { expr }` or `unless { expr }`) -/ +partial def parseCond : Parser Cond := do + let kind ← parseCondKeyword + char' '{' + let body ← expr + char' '}' + return { kind, body } +where + parseCondKeyword : Parser Ident := do + let i ← rawIdent + if i == "when" || i == "unless" then return classifyIdent i + else fail s!"expected 'when' or 'unless', got '{i}'" + +/-- Parse a VariableDef -/ +partial def variableDef : Parser VariableDef := do + let var ← parseIdent + -- Optional: 'is' Add (entity type constraint) + let entityType ← if (← tryKeyword "is") then some <$> addExpr else pure none + -- Optional: RelOp Expr (inequality constraint) + let ineq ← do + match ← tryRelOp with + | some op => + let e ← expr + pure (some (op, e)) + | none => pure none + return { var, entityType, ineq } + +/-- Parse comma-separated variable defs until ')' -/ +partial def varDefList : Parser (List VariableDef) := do + match ← peek? with + | some ')' => return [] + | _ => + let first ← variableDef + let rest ← varDefListTail + return first :: rest +where + varDefListTail : Parser (List VariableDef) := do + if (← (attempt (char' ',') *> pure true) <|> pure false) then + let v ← variableDef + let rest ← varDefListTail + return v :: rest + else + return [] + +/-- Parse a Policy -/ +partial def parsePolicy : Parser Policy := do + -- Parse annotations + let mut annotations : List Annotation := [] + while (← (attempt (skipChar '@' *> pure true)) <|> pure false) do + let name ← parseIdent + let value ← if (← (attempt (char' '(' *> pure true)) <|> pure false) then + let s ← stringLit + char' ')' + pure (some (.string s)) + else + pure none + annotations := annotations ++ [Annotation.mk name value] + let effect ← parseIdent + char' '(' + -- Parse variable defs separated by commas + let vars ← varDefList + char' ')' + -- Parse conditions (when/unless blocks) + let mut conds : List Cond := [] + while true do + match ← (attempt (parseCond >>= fun c => pure (some c))) <|> pure none with + | some c => conds := conds ++ [c] + | none => break + char' ';' + return .policy { id := "", annotations, effect, vars, conds } + +/-- Parse a Policies (sequence of policies) -/ +partial def parsePolicies : Parser Policies := do + wsAndComments + let mut ps : List Policy := [] + while !(← isEof) do + ps := ps ++ [← parsePolicy] + return { ps } + +/-- Top-level entry point: parse a string into a `Policies` CST -/ +def parse (input : String) : Except String Policies := + match (parsePolicies <* eof).run input with + | .ok res => .ok res + | .error err => .error err + +end Cedar.Frontend.Cst.Parser + +end diff --git a/cedar-lean/Cedar/Slice/PolicySlice.lean b/cedar-lean/Cedar/Slice/PolicySlice.lean index d19a037a8..a2dba0aa3 100644 --- a/cedar-lean/Cedar/Slice/PolicySlice.lean +++ b/cedar-lean/Cedar/Slice/PolicySlice.lean @@ -14,7 +14,9 @@ limitations under the License. -/ -import Cedar.Spec +module + +public import Cedar.Spec /-! This file defines a simple policy slicing algorithm that is based @@ -28,11 +30,11 @@ open Cedar.Spec /-- A policy bound consists of optional `principal` and `resource` entities. -/ -structure PolicyBound where +public structure PolicyBound where principalBound : Option EntityUID resourceBound : Option EntityUID -def inSomeOrNone (uid : EntityUID) (opt : Option EntityUID) (entities : Entities) : Bool := +public def inSomeOrNone (uid : EntityUID) (opt : Option EntityUID) (entities : Entities) : Bool := match opt with | .some uid' => inₑ uid uid' entities | .none => true @@ -42,7 +44,7 @@ A bound is satisfied by a request and store if the request principal and resource fields are descendents of the corresponding bound fields (or if those bound fields are `none`). -/ -def satisfiedBound (bound : PolicyBound) (request : Request) (entities : Entities) : Bool := +public def satisfiedBound (bound : PolicyBound) (request : Request) (entities : Entities) : Bool := inSomeOrNone request.principal bound.principalBound entities ∧ inSomeOrNone request.resource bound.resourceBound entities @@ -50,21 +52,21 @@ def satisfiedBound (bound : PolicyBound) (request : Request) (entities : Entitie /-- A bound analysis takes as input a policy and returns a PolicyBound. -/ -abbrev BoundAnalysis := Policy → PolicyBound +public abbrev BoundAnalysis := Policy → PolicyBound /-- A bound-based slicing algorithm takes as input a bound analysis, request, entities, and policies, and filters out the policies whose bound is not satisfied by the request and entities. -/ -def BoundAnalysis.slice (ba : BoundAnalysis) (request : Request) (entities : Entities) (policies : Policies) : Policies := +public def BoundAnalysis.slice (ba : BoundAnalysis) (request : Request) (entities : Entities) (policies : Policies) : Policies := policies.filter (fun policy => satisfiedBound (ba policy) request entities) /-- Scope-based bound analysis extracts the bound from the policy scope. -/ -def scopeAnalysis (policy : Policy) : PolicyBound := +public def scopeAnalysis (policy : Policy) : PolicyBound := { principalBound := policy.principalScope.scope.bound, resourceBound := policy.resourceScope.scope.bound, diff --git a/cedar-lean/Cedar/Spec/Frontend.lean b/cedar-lean/Cedar/Spec/Frontend.lean new file mode 100644 index 000000000..dcb570546 --- /dev/null +++ b/cedar-lean/Cedar/Spec/Frontend.lean @@ -0,0 +1,20 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + + +module + +public import Cedar.Frontend.Cst diff --git a/cedar-lean/Cedar/Spec/Value.lean b/cedar-lean/Cedar/Spec/Value.lean index 14dfdd2e2..d725bc59c 100644 --- a/cedar-lean/Cedar/Spec/Value.lean +++ b/cedar-lean/Cedar/Spec/Value.lean @@ -27,6 +27,13 @@ open Cedar.Data ----- Definitions ----- +public inductive CstError where + | stringError + | nameError + | unsupportedError + | arityError + | translationError + public inductive Error where | entityDoesNotExist | attrDoesNotExist @@ -34,6 +41,8 @@ public inductive Error where | typeError | arithBoundsError | extensionError + -- CST only errors + | cstError (c : CstError) public abbrev Result (α) := Except Error α @@ -156,6 +165,7 @@ public instance : Coe Value (Result (Data.Set Value)) where ----- Derivations ----- deriving instance Repr, DecidableEq, BEq for Except +deriving instance Repr, DecidableEq for CstError deriving instance Repr, DecidableEq for Error deriving instance Repr, DecidableEq, Inhabited, Lean.ToJson for Name deriving instance Repr, DecidableEq, Inhabited for EntityType diff --git a/cedar-lean/Cedar/Thm.lean b/cedar-lean/Cedar/Thm.lean index 5bc55a7ee..12347babc 100644 --- a/cedar-lean/Cedar/Thm.lean +++ b/cedar-lean/Cedar/Thm.lean @@ -25,3 +25,4 @@ import Cedar.Thm.WellTyped import Cedar.Thm.TPE import Cedar.Thm.BatchedEvaluator import Cedar.Thm.WellTypedVerification +import Cedar.Thm.Frontend diff --git a/cedar-lean/Cedar/Thm/Frontend.lean b/cedar-lean/Cedar/Thm/Frontend.lean new file mode 100644 index 000000000..354a40a3c --- /dev/null +++ b/cedar-lean/Cedar/Thm/Frontend.lean @@ -0,0 +1,383 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +import Cedar.Spec +import Cedar.Frontend.Cst +import Cedar.Frontend.Cst.Semantics +import Cedar.Frontend.Cst.ToAst +import Cedar.Thm.Frontend.Translation.AuxComplete +import Cedar.Thm.Frontend.Translation.AuxSound +import Cedar.Thm.Frontend.Translation.ExprComplete +import Cedar.Thm.Frontend.Translation.ExprTranslation +import Cedar.Thm.Frontend.Translation.PolicyToExpr +import Cedar.Thm.Frontend.CstSlice +import Cedar.Thm.Frontend.Authorizer +import Cedar.Thm.Frontend.Parser +import Cedar.Thm.Validation +namespace Cedar.Thm + +open Cedar.Data +open Cedar.Spec +open Cedar.Frontend +open Cedar.Validation + +/-- When `toPolicy?` succeeds, the CST policy's expression also translates to AST. -/ +theorem toPolicy?_implies_toAExpr? + {cp : Cst.Policy} {ap : Spec.Policy} : + cp.toPolicy? = some ap → + ∃ ae, cp.toExpr.toAExpr? = some ae := by + intro htrans + obtain ⟨p⟩ := cp + simp only [Cst.Policy.toPolicy?, Cst.PolicyImpl.toPolicy?, bind, Option.bind_eq_some_iff, + Option.some.injEq] at htrans + obtain ⟨eff, heff, ⟨ps, acts, rs⟩, hsc, conds, hconds, _⟩ := htrans + -- Invert `extractScope?`: exactly three scope variables. + simp only [Cst.Policy.toExpr, Cst.PolicyImpl.toExpr] + match hvars : p.vars, hsc with + | [a, b, c], hsc => + simp only [Cst.extractScope?, bind, Option.bind_eq_some_iff] at hsc + obtain ⟨ps', hps, as', has, rs', hrs, _⟩ := hsc + -- Each variable leaf translates. + obtain ⟨lp, hlp⟩ := principal_leaf_isSome hps + obtain ⟨la, hla⟩ := action_leaf_isSome has + obtain ⟨lr, hlr⟩ := resource_leaf_isSome hrs + -- The variable-expression list translates. + have hvarsMapM : ∃ r, ([a, b, c].map Cst.VariableDef.toExpr).mapM Cst.Expr.toAExpr? = some r := by + refine ⟨[lp, la, lr], ?_⟩ + simp [List.map_cons, List.mapM_cons, hlp, hla, hlr] + -- The condition-expression list translates. + have hcondsMapM := conds_mapM_toAExpr_isSome (by simpa [Cst.toConditions?] using hconds) + -- The append translates. + obtain ⟨r, hr⟩ := mapM_append_isSome hvarsMapM hcondsMapM + -- Conclude via `foldAnd_toAExpr`. + exact ⟨_, foldAnd_toAExpr _ r hr⟩ + | [], hsc => simp [Cst.extractScope?] at hsc + | [_], hsc => simp [Cst.extractScope?] at hsc + | [_, _], hsc => simp [Cst.extractScope?] at hsc + | _ :: _ :: _ :: _ :: _, hsc => simp [Cst.extractScope?] at hsc + +theorem policy_satisfied_agrees (cp : Cst.Policy) (ap : Spec.Policy) + (req : Request) (es : Entities) : + cp.toPolicy? = some ap → + Cst.satisfied cp req es = satisfied ap req es := by + intro htrans + obtain ⟨ae, hae⟩ := toPolicy?_implies_toAExpr? htrans + have heq : cp.toExpr.evaluate req es = evaluate ap.toExpr req es := + (expr_to_expr_sound hae).symm.trans + (policy_to_expr_sound cp ap cp.toExpr ae req es htrans rfl hae) + unfold Cst.satisfied Spec.satisfied + rw [heq] + +/-- Under a successful translation, `extractScope?` succeeds, so the new scope + guard in `Cst.hasError` is a no-op and it reduces to the plain + evaluate-the-policy-expression check. -/ +theorem cst_hasError_eq_of_toPolicy {cp : Cst.Policy} {ap : Spec.Policy} + {req : Request} {es : Entities} (htrans : cp.toPolicy? = some ap) : + Cst.hasError cp req es = + (match cp.toExpr.evaluate req es with | .ok _ => false | .error _ => true) := by + obtain ⟨p⟩ := cp + have hpp : p.toPolicy? = some ap := htrans + have hcond : ¬ (p.toPolicy?.isNone = true) := by rw [hpp]; simp + simp only [Cst.hasError, if_neg hcond] + rfl + +theorem policy_hasError_agrees (cp : Cst.Policy) (ap : Spec.Policy) + (req : Request) (es : Entities) : + cp.toPolicy? = some ap → + Cst.hasError cp req es = hasError ap req es := by + intro htrans + obtain ⟨ae, hae⟩ := toPolicy?_implies_toAExpr? htrans + have heq : cp.toExpr.evaluate req es = evaluate ap.toExpr req es := + (expr_to_expr_sound hae).symm.trans + (policy_to_expr_sound cp ap cp.toExpr ae req es htrans rfl hae) + rw [cst_hasError_eq_of_toPolicy htrans, heq] + rfl + +/-- Per-policy agreement of the error check. -/ +theorem policy_errored_agrees (cp : Cst.Policy) (ap : Spec.Policy) + (req : Request) (es : Entities) + (htrans : cp.toPolicy? = some ap) : + (if Cst.hasError cp req es then some cp.id else none) = errored ap req es := by + have hhe : Cst.hasError cp req es = hasError ap req es := + policy_hasError_agrees cp ap req es htrans + have hid : cp.id = ap.id := (toPolicy?_id_eq htrans).symm + simp only [errored, hhe, hid] + +/-- Per-policy agreement of the effect-filtered satisfaction check. -/ +theorem policy_satisfiedWithEffect_agrees (cp : Cst.Policy) (ap : Spec.Policy) + (req : Request) (es : Entities) (eff : Effect) + (htrans : cp.toPolicy? = some ap) : + (if Cst.satisfiedWithEffect eff cp req es then some cp.id else none) + = Spec.satisfiedWithEffect eff ap req es := by + obtain ⟨p⟩ := cp + have htrans' := htrans + simp only [Cst.Policy.toPolicy?, Cst.PolicyImpl.toPolicy?, bind, Option.bind_eq_some_iff, + Option.some.injEq] at htrans' + obtain ⟨e0, he0, ⟨ps, acts, rs⟩, hsc, conds, hconds, heq⟩ := htrans' + have heffeq : e0 = ap.effect := by + have := congrArg Spec.Policy.effect heq; simpa using this + have heff : Cst.Ident.toEffect? p.effect = some ap.effect := by + rw [he0, heffeq] + have hsat : Cst.satisfied (.policy p) req es = satisfied ap req es := + policy_satisfied_agrees (.policy p) ap req es htrans + have hid : (Cst.Policy.policy p).id = ap.id := (toPolicy?_id_eq htrans).symm + simp only [Cst.satisfiedWithEffect, Spec.satisfiedWithEffect, heff, hsat, hid] + by_cases hs : satisfied ap req es + · simp only [hs, if_true, Bool.and_true] + by_cases he : ap.effect = eff + · simp [he] + · simp [he] + · simp [hs] + +theorem satisfiedPolicies_agrees (cps : Cst.Policies) (aps : Spec.Policies) + (req : Request) (es : Entities) (eff : Effect) : + cps.toPolicies? = some aps → + Cst.satisfiedPolicies eff cps req es = satisfiedPolicies eff aps req es := by + intro htrans + have hforall := toPolicies?_forall₂ htrans + -- The two filterMaps agree pointwise. + simp only [Cst.satisfiedPolicies, Spec.satisfiedPolicies] + congr 1 + apply filterMap_congr_forall₂ hforall + intro cp ap htp + exact policy_satisfiedWithEffect_agrees cp ap req es eff htp + +theorem errorPolicies_agrees (cps : Cst.Policies) (aps : Spec.Policies) + (req : Request) (es : Entities) : + cps.toPolicies? = some aps → + Cst.errorPolicies cps req es = errorPolicies aps req es := by + intro htrans + have hforall := toPolicies?_forall₂ htrans + simp only [Cst.errorPolicies, Spec.errorPolicies] + congr 1 + apply filterMap_congr_forall₂ hforall + intro cp ap htp + exact policy_errored_agrees cp ap req es htp + +theorem translation_is_sound (cps : Cst.Policies) (aps : Spec.Policies) +(req : Request) (es : Entities) : + cps.toPolicies? = some aps → + Cst.isAuthorized req es cps = Spec.isAuthorized req es aps := by + intro htrans + have hforbids := satisfiedPolicies_agrees cps aps req es .forbid htrans + have hpermits := satisfiedPolicies_agrees cps aps req es .permit htrans + have herrors := errorPolicies_agrees cps aps req es htrans + simp [Cst.isAuthorized, Spec.isAuthorized] + simp [hforbids, hpermits, herrors] + +theorem noHasError_translates (cp : Cst.Policy) (req : Request) (es : Entities) : + ¬ Cst.hasError cp req es → + ∃ ap, cp.toPolicy? = some ap := by + intro h + obtain ⟨p⟩ := cp + cases hp : p.toPolicy? with + | none => + exfalso; apply h + simp only [Cst.hasError, hp, Option.isNone_none, if_true] + | some ap => + exact ⟨ap, by simp [Cst.Policy.toPolicy?, hp]⟩ + +theorem translation_is_complete (cps : Cst.Policies) (req : Request) (es : Entities) : + ∀ cp ∈ cps.ps, cp.id ∉ (Cst.isAuthorized req es cps).erroringPolicies → + ∃ ap, cp.toPolicy? = some ap := by + intro cp hmem hnoterr + apply noHasError_translates cp req es + intro herr + apply hnoterr + have herrp : cp.id ∈ Cst.errorPolicies cps req es := by + simp only [Cst.errorPolicies, Set.mem_make] + exact List.mem_filterMap.mpr ⟨cp, hmem, by simp [herr]⟩ + simp only [Cst.isAuthorized] + split <;> exact herrp + + +/-- Translating a sound CST policy slice yields a sound AST policy slice. -/ +theorem cst_sound_slice_translates + {req : Request} {entities : Entities} {slice policies : Cst.Policies} + {sps aps : Spec.Policies} + (hsound : Cst.IsSoundPolicySlice req entities slice policies) + (hsps : slice.toPolicies? = some sps) + (haps : policies.toPolicies? = some aps) : + IsSoundPolicySlice req entities sps aps := by + obtain ⟨hsub, hrest⟩ := hsound + have hfs := toPolicies?_forall₂ hsps + have hfp := toPolicies?_forall₂ haps + refine ⟨?_, ?_⟩ + · intro ap hap + obtain ⟨cp, hcp_mem, hcp⟩ := forall₂_exists_mem_right hfs hap + obtain ⟨ap', hap'_mem, hr'⟩ := forall₂_exists_mem_left hfp (hsub hcp_mem) + have : ap = ap' := by rw [hcp] at hr'; exact Option.some.inj hr' + rw [this]; exact hap'_mem + · intro ap hap_aps hap_not_sps + obtain ⟨cp, hcp_mem_pol, hcp⟩ := forall₂_exists_mem_right hfp hap_aps + have hcp_not_slice : cp ∉ slice.ps := by + intro hcp_slice + obtain ⟨ap'', hap''_mem, hr''⟩ := forall₂_exists_mem_left hfs hcp_slice + have : ap = ap'' := by rw [hcp] at hr''; exact Option.some.inj hr'' + rw [this] at hap_not_sps + exact hap_not_sps hap''_mem + obtain ⟨hsat, herr⟩ := hrest cp hcp_mem_pol hcp_not_slice + rw [← policy_satisfied_agrees cp ap req entities hcp, + ← policy_hasError_agrees cp ap req entities hcp] + exact ⟨hsat, herr⟩ + + +/-- +Scope analysis computed natively on a CST policy agrees with scope analysis +computed on the AST policy it translates to. +-/ +theorem Cst.translation_preserves_scopeAnalysis + {cp : Cst.Policy} {ap : Policy} + (htrans : cp.toPolicy? = some ap) : + ∃ h : (Cst.prVars? cp).isSome, + Cst.scopeAnalysis cp h = Cedar.Slice.scopeAnalysis ap := by + exists (policy_translation_success_prVars_isSome' htrans) + apply translation_preserves_scopeAnalysis' htrans + +/-- +CST policy slicing soundness: `Cst.isAuthorized` produces the same result for a +sound slice (subset) of a collection of CST policies as it does for the original +policies. +-/ +theorem Cst.isAuthorized_eq_for_sound_policy_slice + (req : Request) (entities : Entities) (slice policies : Cst.Policies) + (htrans : (policies.toPolicies?).isSome) : + Cst.IsSoundPolicySlice req entities slice policies → + Cst.isAuthorized req entities slice = Cst.isAuthorized req entities policies := by + intro hsound + obtain ⟨aps, haps⟩ := Option.isSome_iff_exists.mp htrans + obtain ⟨sps, hsps⟩ := slice_toPolicies?_isSome hsound.1 haps + have hast := cst_sound_slice_translates hsound hsps haps + rw [translation_is_sound _ _ req entities hsps, + _root_.Cedar.Thm.isAuthorized_eq_for_sound_policy_slice req entities sps aps hast, + ← translation_is_sound _ _ req entities haps] + +/-- +A sound CST bound analysis produces sound CST policy slices. +-/ +theorem Cst.sound_bound_analysis_produces_sound_slices + (ba : Cst.BoundAnalysis) (request : Request) (entities : Entities) + (policies : Cst.Policies) + (htrans : (policies.toPolicies?).isSome) : + Cst.IsSoundBoundAnalysis ba → + ∃ (h : ∀ policy ∈ policies.ps, (Cst.prVars? policy).isSome), + Cst.IsSoundPolicySlice request entities + (Cst.BoundAnalysis.slice ba request entities policies h) policies := by + intro hba + have hwf := policies_translation_success_prVars_isSome htrans + exists hwf + refine ⟨cst_bound_slice_subset ba request entities policies hwf, ?_⟩ + intro policy hmem hnotin + obtain ⟨hsat_imp, herr_imp⟩ := hba policy (hwf policy hmem) + (policy_toPolicy?_isSome_of_mem htrans hmem) request entities + exact ⟨ + fun hsat => hnotin (cst_bound_slice_kept ba request entities policies hwf hmem (hsat_imp hsat)), + fun herr => hnotin (cst_bound_slice_kept ba request entities policies hwf hmem (herr_imp herr))⟩ + +/-- +CST scope-based bounds are sound. +-/ +theorem Cst.scope_bound_is_sound (policy : Cst.Policy) + (htrans : (policy.toPolicy?).isSome) : + ∃ h : (Cst.prVars? policy).isSome, + Cst.IsSoundPolicyBound (Cst.scopeAnalysis policy h) policy := by + obtain ⟨ap, hap⟩ := Option.isSome_iff_exists.mp htrans + exists (policy_translation_success_prVars_isSome' hap) + intro req es + have hscope := translation_preserves_scopeAnalysis' hap (policy_translation_success_prVars_isSome' hap) + have hsat := policy_satisfied_agrees policy ap req es hap + have herr := policy_hasError_agrees policy ap req es hap + rw [hscope, hsat, herr] + exact _root_.Cedar.Thm.scope_bound_is_sound ap req es + +/-- +CST scope-based bound analysis is sound. +-/ +theorem Cst.scope_analysis_is_sound : + Cst.IsSoundBoundAnalysis Cst.scopeAnalysis := by + intro policy _ hpt + obtain ⟨_, hsound⟩ := Cst.scope_bound_is_sound policy hpt + exact hsound + +/-- +CST scope-based slicing is sound: `Cst.isAuthorized` produces the same result for +a scope-based slice of a collection of CST policies as it does for the original +policies. +-/ +theorem Cst.isAuthorized_eq_for_scope_based_policy_slice + (request : Request) (entities : Entities) (policies : Cst.Policies) + (htrans : (policies.toPolicies?).isSome) : + ∃ (hwf : ∀ policy ∈ policies.ps, (Cst.prVars? policy).isSome), + Cst.isAuthorized request entities + (Cst.BoundAnalysis.slice Cst.scopeAnalysis request entities policies hwf) = + Cst.isAuthorized request entities policies := by + exists (policies_translation_success_prVars_isSome htrans) + obtain ⟨aps, htrans'⟩ := Option.isSome_iff_exists.mp htrans + have hslice := cst_slice_chooses_same_policies' request entities htrans' + (policies_translation_success_prVars_isSome htrans) + rw [translation_is_sound _ _ request entities hslice, + _root_.Cedar.Thm.isAuthorized_eq_for_scope_based_policy_slice request entities aps, + ← translation_is_sound _ _ request entities htrans'] + + +/-- If a translated CST expression is well-typed, evaluating the CST expression +never throws a `typeError`. -/ +theorem validated_no_type_error + {cst : Cst.Expr} {ast : Spec.Expr} {c₁ c₂ : Capabilities} {ty : TypedExpr} + {env : TypeEnv} {request : Request} {entities : Entities} + (htrans : cst.toAExpr? = some ast) + (hcap : CapabilitiesInvariant c₁ request entities) + (hwf : InstanceOfWellFormedEnvironment request entities env) + (hwt : typeOf ast c₁ env = .ok (ty, c₂)) : + cst.evaluate request entities ≠ .error .typeError := by + intro hcontra + obtain ⟨_, v, hev, _⟩ := type_of_is_sound hcap hwf hwt + have hast : evaluate ast request entities = .error .typeError := by + rw [expr_to_expr_sound htrans, hcontra] + simp [EvaluatesTo, hast] at hev + +/-- +**CST validation soundness (policy-set level).** The CST counterpart of +`validation_is_sound`: if a set of CST policies translates to a set of AST +policies that is validated with respect to the schema, and the request +and entities are consistent with the schema, then evaluating each CST policy's +expression never throws a `typeError` (it produces a boolean value or one of the +runtime-only errors `entityDoesNotExist`, `extensionError`, `arithBoundsError`). -/ + +theorem cst_validation_is_sound (cps : Cst.Policies) (aps : Policies) + (schema : Schema) (request : Request) (entities : Entities) : + cps.toPolicies? = some aps → + schema.validateWellFormed = .ok () → + validate aps schema = .ok () → + validateRequest schema request = .ok () → + validateEntities schema entities = .ok () → + ∀ cp ∈ cps.ps, cp.toExpr.evaluate request entities ≠ .error .typeError := by + intro htrans hwf hval hreq hent cp hcp + have hbool := validation_is_sound aps schema request entities hwf hval hreq hent + obtain ⟨ap, hap_mem, hcp_ap⟩ := + List.forall₂_implies_all_left (toPolicies?_forall₂ htrans) cp hcp + obtain ⟨_, hev⟩ := hbool ap hap_mem + obtain ⟨ae, hae⟩ := toPolicy?_implies_toAExpr? hcp_ap + have h1 : evaluate ae request entities = cp.toExpr.evaluate request entities := + expr_to_expr_sound hae + have h2 : evaluate ae request entities = evaluate ap.toExpr request entities := + policy_to_expr_sound cp ap cp.toExpr ae request entities hcp_ap rfl hae + intro hcontra + have hap_te : evaluate ap.toExpr request entities = .error .typeError := by + rw [← h2, h1]; exact hcontra + simp [EvaluatesTo, hap_te] at hev + +end Cedar.Thm diff --git a/cedar-lean/Cedar/Thm/Frontend/Authorizer.lean b/cedar-lean/Cedar/Thm/Frontend/Authorizer.lean new file mode 100644 index 000000000..2552a5e91 --- /dev/null +++ b/cedar-lean/Cedar/Thm/Frontend/Authorizer.lean @@ -0,0 +1,112 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +import Cedar.Spec +import Cedar.Frontend.Cst +import Cedar.Frontend.Cst.Semantics +import Cedar.Thm.Data.Set + +namespace Cedar.Thm.Cst + +open Cedar.Data +open Cedar.Spec +open Cedar.Frontend +open Cedar.Frontend.Cst hiding Expr ExprImpl ExprData OrExpr AndExpr AddExpr MultExpr Name Policy PolicyImpl Policies Ident Literal Primary Member MemAccess Unary Relation RelOp Cond VariableDef Ref RecInit Str + + +def HasSatisfiedEffect (effect : Effect) (request : Request) (entities : Entities) (policies : Cst.Policies) : Prop := + ∃ policy ∈ policies.ps, + Cst.satisfiedWithEffect effect policy request entities = true + +theorem satisfied_iff_satisfiedPolicies_non_empty {effect : Effect} {request : Request} {entities : Entities} {policies : Cst.Policies} : + HasSatisfiedEffect effect request entities policies ↔ (Cst.satisfiedPolicies effect policies request entities).isEmpty = false := by + simp only [HasSatisfiedEffect, Cst.satisfiedPolicies, Set.isEmpty_make_eq_false] + constructor + · rintro ⟨p, hp, hsat⟩ + apply List.ne_nil_of_mem (a := p.id) + rw [List.mem_filterMap] + exact ⟨p, hp, by simp [hsat]⟩ + · intro hne + obtain ⟨id, hid⟩ := List.exists_mem_of_ne_nil _ hne + rw [List.mem_filterMap] at hid + obtain ⟨pol, hpair, hf⟩ := hid + refine ⟨pol, hpair, ?_⟩ + by_cases h : Cst.satisfiedWithEffect effect pol request entities = true + · exact h + · simp [h] at hf + +def IsExplicitlyForbidden := HasSatisfiedEffect .forbid + +theorem explicitly_forbidden_iff_satisfying_forbid + (req : Request) (entities : Entities) (policies : Cst.Policies) : + IsExplicitlyForbidden req entities policies ↔ (Cst.satisfiedPolicies .forbid policies req entities).isEmpty = false := by + unfold IsExplicitlyForbidden + simp [satisfied_iff_satisfiedPolicies_non_empty] + +def IsExplicitlyPermitted := HasSatisfiedEffect .permit + +theorem explicitly_permitted_iff_satisfying_permit + (req : Request) (entities : Entities) (policies : Cst.Policies) : + IsExplicitlyPermitted req entities policies ↔ (Cst.satisfiedPolicies .permit policies req entities).isEmpty = false := by + unfold IsExplicitlyPermitted + simp [satisfied_iff_satisfiedPolicies_non_empty] + +theorem forbid_trumps_permit + (request : Request) (entities : Entities) (policies : Cst.Policies) : + (IsExplicitlyForbidden request entities policies) → + (Cst.isAuthorized request entities policies).decision = .deny := by + intro h + unfold Cst.isAuthorized + rw [explicitly_forbidden_iff_satisfying_forbid] at h + simp [h] + +theorem allowed_only_if_explicitly_permitted (request : Request) (entities : Entities) (policies : Cst.Policies) : + (Cst.isAuthorized request entities policies).decision = .allow → + IsExplicitlyPermitted request entities policies := by + unfold Cst.isAuthorized + generalize hf: (Cst.satisfiedPolicies .forbid policies request entities) = forbids + generalize hp: (Cst.satisfiedPolicies .permit policies request entities) = permits + simp [Bool.and_eq_true] + cases forbids.isEmpty <;> simp + cases hpemp : permits.isEmpty with + | true => simp + | false => + simp + rw [←hp] at hpemp + have h := explicitly_permitted_iff_satisfying_permit request entities policies + simp [h]; exact hpemp + +theorem default_deny + (request : Request) (entities : Entities) (policies : Cst.Policies) : + ¬ IsExplicitlyPermitted request entities policies → + (Cst.isAuthorized request entities policies).decision = .deny := by + intro h + generalize hdec : (Cst.isAuthorized request entities policies).decision = dec + by_contra hcontra + cases dec with + | allow => + have hperm := allowed_only_if_explicitly_permitted request entities policies hdec + contradiction + | deny => contradiction + +theorem explicit_allow + (request : Request) (entities : Entities) (policies : Cst.Policies) : + (Cst.isAuthorized request entities policies).decision = .allow → + IsExplicitlyPermitted request entities policies := + allowed_only_if_explicitly_permitted request entities policies + + +end Cedar.Thm.Cst diff --git a/cedar-lean/Cedar/Thm/Frontend/CstSlice.lean b/cedar-lean/Cedar/Thm/Frontend/CstSlice.lean new file mode 100644 index 000000000..7e777602f --- /dev/null +++ b/cedar-lean/Cedar/Thm/Frontend/CstSlice.lean @@ -0,0 +1,470 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +import Cedar.Slice.PolicySlice +import Cedar.Frontend.Cst.Slice +import Cedar.Thm.Authorization.Authorizer +import Cedar.Thm.Frontend.Translation.AuxSound +import Cedar.Thm.PolicySlice + +namespace Cedar.Thm +open Cedar.Spec Cedar.Slice Cedar.Data +open Cedar.Frontend +open Cedar.Frontend.Cst hiding Expr ExprImpl ExprData OrExpr AndExpr AddExpr MultExpr Name Policy PolicyImpl Policies Ident Literal Primary Member MemAccess Unary Relation RelOp Cond VariableDef Ref RecInit Str + + + +/-! +Key theorems in this file: + +* `policy_translation_success_prVars_isSome`: Whenever a CST policy successfully + translates to the AST, its principal/resource scope variables can be extracted + via `prVars?` (i.e. `prVars?` is `isSome`). This well-formedness fact is the + precondition required to run scope analysis on the CST. (The policy-store level + variant `policies_translation_success_prVars_isSome` lives in + `Cedar/Thm/Frontend/PolicySlice.lean`.) + +* `translation_preserves_scopeAnalysis'`: Scope analysis computed natively on a CST + policy (`Cst.scopeAnalysis`) agrees with scope analysis computed on the AST policy + it translates to (`scopeAnalysis`). (The packaged form + `translation_preserves_scopeAnalysis` lives in `Cedar/Thm/PolicySlice.lean`.) + +* `cst_slice_chooses_same_policies`: Lifting the previous result to whole policy + stores, the CST slice and the AST slice select corresponding policies in lockstep. + +* `cst_slice_is_sound`: The headline result. Authorizing a request against the CST + slice produces the same decision as authorizing against the full CST policy store, so slicing on the CST is decision-preserving. +-/ + +/-- `toPRScope?` succeeding implies the variable's bound is interpretable. -/ +private theorem varBoundWF_of_toPRScope? {v : Cst.VariableDef} (h : (v.toPRScope?).isSome) : + varBoundWF v = true := by + cases hineq : v.ineq with + | none => + cases het : v.entityType with + | none => simp [varBoundWF, hineq, het] + | some t => simp [varBoundWF, hineq, het] + | some opE => + obtain ⟨op, e⟩ := opE + cases het : v.entityType with + | none => + cases op with + | rEq => + simp only [Cst.VariableDef.toPRScope?, hineq, het] at h + cases hu : e.toEntityUID? with + | none => rw [hu] at h; simp at h + | some x => simp [varBoundWF, hineq, het, hu] + | rIn => + simp only [Cst.VariableDef.toPRScope?, hineq, het] at h + cases hu : e.toEntityUID? with + | none => rw [hu] at h; simp at h + | some x => simp [varBoundWF, hineq, het, hu] + | rLess | rLessEq | rGreater | rGreaterEq | rNotEq => + simp [Cst.VariableDef.toPRScope?, hineq, het] at h + | some t => + cases op with + | rIn => + simp only [Cst.VariableDef.toPRScope?, hineq, het] at h + cases hu : e.toEntityUID? with + | none => rw [hu] at h; simp at h + | some x => simp [varBoundWF, hineq, het, hu] + | rEq | rLess | rLessEq | rGreater | rGreaterEq | rNotEq => + simp [Cst.VariableDef.toPRScope?, hineq, het] at h + +private theorem toPrincipalScope?_inv {v : Cst.VariableDef} {ps : PrincipalScope} + (h : v.toPrincipalScope? = some ps) : v.var = .idPrincipal ∧ (v.toPRScope?).isSome := by + unfold Cst.VariableDef.toPrincipalScope? at h + split at h + · rename_i hvar + refine ⟨hvar, ?_⟩ + simp only [bind, Option.bind_eq_some_iff] at h + obtain ⟨scope, hscope, _⟩ := h + rw [hscope]; rfl + · simp at h + +private theorem toResourceScope?_inv {v : Cst.VariableDef} {rs : ResourceScope} + (h : v.toResourceScope? = some rs) : v.var = .idResource ∧ (v.toPRScope?).isSome := by + unfold Cst.VariableDef.toResourceScope? at h + split at h + · rename_i hvar + refine ⟨hvar, ?_⟩ + simp only [bind, Option.bind_eq_some_iff] at h + obtain ⟨scope, hscope, _⟩ := h + rw [hscope]; rfl + · simp at h + +private theorem toActionScope?_var {v : Cst.VariableDef} {acts : ActionScope} + (h : v.toActionScope? = some acts) : v.var = .idAction := by + cases hvar : v.var <;> + simp_all [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?, + bind, Option.bind_eq_some_iff] + +-- When the policy translation is successful, the three scopes can be extracted +theorem policy_translation_success_prVars_isSome + {cp : Cst.Policy} : + (cp.toPolicy?).isSome → + (prVars? cp).isSome := by + intro htrans + obtain ⟨ap, hap⟩ := Option.isSome_iff_exists.mp htrans + obtain ⟨p⟩ := cp + simp only [Cst.Policy.toPolicy?, Cst.PolicyImpl.toPolicy?, bind, Option.bind_eq_some_iff, + Option.some.injEq] at hap + obtain ⟨eff, heff, ⟨ps, acts, rs⟩, hsc, conds, hconds, _⟩ := hap + match hvars : p.vars, hsc with + | [a, b, c], hsc => + simp only [extractScope?, bind, Option.bind_eq_some_iff] at hsc + obtain ⟨ps', hps, as', has, rs', hrs, _⟩ := hsc + have ⟨hpvar, hppr⟩ := toPrincipalScope?_inv hps + have hbvar := toActionScope?_var has + have ⟨hrvar, hrpr⟩ := toResourceScope?_inv hrs + have hwfa := varBoundWF_of_toPRScope? hppr + have hwfc := varBoundWF_of_toPRScope? hrpr + simp [prVars?, hvars, hpvar, hbvar, hrvar, hwfa, hwfc] + | [], hsc => simp [extractScope?] at hsc + | [_], hsc => simp [extractScope?] at hsc + | [_, _], hsc => simp [extractScope?] at hsc + | _ :: _ :: _ :: _ :: _, hsc => simp [extractScope?] at hsc + +theorem policy_translation_success_prVars_isSome' + {cp : Cst.Policy} {ap : Policy} : + cp.toPolicy? = some ap → + (prVars? cp).isSome := by + intro htrans + have h : (cp.toPolicy?).isSome := by + rw [Option.isSome_iff_exists]; exists ap + apply (policy_translation_success_prVars_isSome h) + +-- When the policies translation is successful, the three scopes can be extracted +theorem policies_translation_success_prVars_isSome + {cps : Cst.Policies} : + (cps.toPolicies?).isSome → + ∀ cp ∈ cps.ps, (prVars? cp).isSome := by + intro htrans + obtain ⟨ps⟩ := cps + simp only [Cst.Policies.toPolicies?] at htrans + rw [Option.isSome_iff_exists] at htrans + obtain ⟨aps, hmap⟩ := htrans + have hall := List.mapM_some_implies_all_some hmap + intro cp hcp; simp at hcp + apply policy_translation_success_prVars_isSome + rw [Option.isSome_iff_exists] + obtain ⟨ap, hap1, hap2⟩ := (hall cp hcp) + exists ap + +theorem policies_translation_success_prVars_isSome' + {cps : Cst.Policies} {aps : Policies} : + cps.toPolicies? = aps → + ∀ cp ∈ cps.ps, (prVars? cp).isSome := by + intro htrans + have h : (cps.toPolicies?).isSome := by + rw [Option.isSome_iff_exists]; exists aps + apply (policies_translation_success_prVars_isSome h) + +/-- The CST-native `varBound?` agrees with the AST `Scope.bound` of the scope the + variable translates to. -/ +private theorem varBound?_eq_scope_bound {v : Cst.VariableDef} {scope : Scope} + (h : v.toPRScope? = some scope) : varBound? v = scope.bound := by + cases hineq : v.ineq with + | none => + cases het : v.entityType with + | none => + simp only [Cst.VariableDef.toPRScope?, hineq, het, Option.some.injEq] at h + subst h; simp [varBound?, hineq, het, Scope.bound] + | some t => + simp only [Cst.VariableDef.toPRScope?, hineq, het, bind, Option.bind_eq_some_iff, + Option.some.injEq] at h + obtain ⟨ety, _, hsc⟩ := h; subst hsc + simp [varBound?, hineq, het, Scope.bound] + | some opE => + obtain ⟨op, e⟩ := opE + cases het : v.entityType with + | none => + cases op with + | rEq => + simp only [Cst.VariableDef.toPRScope?, hineq, het, bind, Option.bind_eq_some_iff, + Option.some.injEq] at h + obtain ⟨eref, hu, hsc⟩ := h; subst hsc + simp [varBound?, hineq, het, Scope.bound, hu] + | rIn => + simp only [Cst.VariableDef.toPRScope?, hineq, het, bind, Option.bind_eq_some_iff, + Option.some.injEq] at h + obtain ⟨eref, hu, hsc⟩ := h; subst hsc + simp [varBound?, hineq, het, Scope.bound, hu] + | rLess | rLessEq | rGreater | rGreaterEq | rNotEq => + simp [Cst.VariableDef.toPRScope?, hineq, het] at h + | some t => + cases op with + | rIn => + simp only [Cst.VariableDef.toPRScope?, hineq, het, bind, Option.bind_eq_some_iff, + Option.some.injEq] at h + obtain ⟨eref, hu, ety, _, hsc⟩ := h; subst hsc + simp [varBound?, hineq, het, Scope.bound, hu] + | rEq | rLess | rLessEq | rGreater | rGreaterEq | rNotEq => + simp [Cst.VariableDef.toPRScope?, hineq, het] at h + +private theorem toPrincipalScope?_some {v : Cst.VariableDef} {ps : PrincipalScope} + (h : v.toPrincipalScope? = some ps) : + ∃ scope, v.toPRScope? = some scope ∧ ps = .principalScope scope := by + unfold Cst.VariableDef.toPrincipalScope? at h + split at h + · simp only [bind, Option.bind_eq_some_iff, Option.some.injEq] at h + obtain ⟨scope, hscope, hps⟩ := h + exact ⟨scope, hscope, hps.symm⟩ + · simp at h + +private theorem toResourceScope?_some {v : Cst.VariableDef} {rs : ResourceScope} + (h : v.toResourceScope? = some rs) : + ∃ scope, v.toPRScope? = some scope ∧ rs = .resourceScope scope := by + unfold Cst.VariableDef.toResourceScope? at h + split at h + · simp only [bind, Option.bind_eq_some_iff, Option.some.injEq] at h + obtain ⟨scope, hscope, hrs⟩ := h + exact ⟨scope, hscope, hrs.symm⟩ + · simp at h + +theorem translation_preserves_scopeAnalysis' + {cp : Cst.Policy} {ap : Policy} + (htrans : cp.toPolicy? = some ap) + (h : (prVars? cp).isSome) : -- redundant, but provides flexibility in future uses + Cst.scopeAnalysis cp h = scopeAnalysis ap := by + obtain ⟨p⟩ := cp + simp only [Cst.Policy.toPolicy?, Cst.PolicyImpl.toPolicy?, bind, Option.bind_eq_some_iff, + Option.some.injEq] at htrans + obtain ⟨eff, heff, ⟨ps, acts, rs⟩, hsc, conds, hconds, hap⟩ := htrans + match hvars : p.vars, hsc with + | [a, b, c], hsc => + simp only [extractScope?, bind, Option.bind_eq_some_iff] at hsc + obtain ⟨ps', hps, as', has, rs', hrs, hsceq⟩ := hsc + obtain ⟨scope_p, hppr, hpseq⟩ := toPrincipalScope?_some hps + have hbvar := toActionScope?_var has + obtain ⟨scope_r, hrpr, hrseq⟩ := toResourceScope?_some hrs + have ⟨hpvar, hpprS⟩ := toPrincipalScope?_inv hps + have ⟨hrvar, hrprS⟩ := toResourceScope?_inv hrs + have hwfa := varBoundWF_of_toPRScope? hpprS + have hwfc := varBoundWF_of_toPRScope? hrprS + have hpr : prVars? (Cst.Policy.policy p) = some (a, c) := by + simp [prVars?, hvars, hpvar, hbvar, hrvar, hwfa, hwfc] + have hba := varBound?_eq_scope_bound hppr + have hbc := varBound?_eq_scope_bound hrpr + simp only [Option.some.injEq, Prod.mk.injEq] at hsceq + obtain ⟨hpe, _, hre⟩ := hsceq + subst hpe; subst hre; subst hap + have hget : (prVars? (Cst.Policy.policy p)).get h = (a, c) := Option.get_of_eq_some h hpr + unfold Cst.scopeAnalysis Cedar.Slice.scopeAnalysis + simp only [hget, hpseq, hrseq, PrincipalScope.scope, ResourceScope.scope, hba, hbc] + | [], hsc => simp [extractScope?] at hsc + | [_], hsc => simp [extractScope?] at hsc + | [_, _], hsc => simp [extractScope?] at hsc + | _ :: _ :: _ :: _ :: _, hsc => simp [extractScope?] at hsc + +def Cst.IsSoundPolicySlice (req : Request) (entities : Entities) (slice policies : Cst.Policies) : Prop := + slice.ps ⊆ policies.ps ∧ + ∀ policy ∈ policies.ps, + policy ∉ slice.ps → + ¬ Cst.satisfied policy req entities ∧ ¬ Cst.hasError policy req entities + +theorem Cst.sound_slice_transitive : + Cst.IsSoundPolicySlice r es slice₁ ps → + Cst.IsSoundPolicySlice r es slice₂ slice₁ → + Cst.IsSoundPolicySlice r es slice₂ ps := by + intro ⟨h_slice₁_sub, h_slice₁_sound⟩ ⟨h_slice₂_sub, h_slice₂_sound⟩ + constructor + · exact List.Subset.trans h_slice₂_sub h_slice₁_sub + · intro p h_mem_ps h_mem_slice₂ + by_cases h_mem_slice₁ : p ∈ slice₁.ps + case pos => + exact h_slice₂_sound p h_mem_slice₁ h_mem_slice₂ + case neg => + exact h_slice₁_sound p h_mem_ps h_mem_slice₁ + +def Cst.IsSoundPolicyBound (bound : PolicyBound) (policy : Cst.Policy) : Prop := + ∀ (req : Request) (entities : Entities), + (Cst.satisfied policy req entities → satisfiedBound bound req entities) ∧ + (Cst.hasError policy req entities → satisfiedBound bound req entities) + +def Cst.IsSoundBoundAnalysis (ba : Cst.BoundAnalysis) : Prop := + ∀ (policy : Cst.Policy) (h : (prVars? policy).isSome), + (policy.toPolicy?).isSome → Cst.IsSoundPolicyBound (ba policy h) policy + +/-- `mapM`-cons helper specialised to `toPolicy?`. -/ +private theorem mapM_toPolicy?_cons {hd : Cst.Policy} {ap : Spec.Policy} + {tl : List Cst.Policy} {r : List Spec.Policy} + (h1 : hd.toPolicy? = some ap) (h2 : tl.mapM Cst.Policy.toPolicy? = some r) : + (hd :: tl).mapM Cst.Policy.toPolicy? = some (ap :: r) := by + simp [List.mapM_cons, h1, h2] + +/-- Core list-level commutation: scope-based slicing on a list of CST policies, + followed by translation, yields the scope-based slice of the translated AST + policies. Proven by induction on the translation `Forall₂`, using + `translation_preserves_scopeAnalysis'` (so the CST and AST `satisfiedBound` + predicates agree on corresponding policies). -/ +private theorem scope_slice_translate + (req : Request) (entities : Entities) : + ∀ (cps : List Cst.Policy) (aps : List Spec.Policy) + (hwf : ∀ policy ∈ cps, (prVars? policy).isSome), + List.Forall₂ (fun cp ap => cp.toPolicy? = some ap) cps aps → + (cps.attach.filterMap (fun x => + if satisfiedBound (Cst.scopeAnalysis x.1 (hwf x.1 x.2)) req entities + then some x.1 else none)).mapM Cst.Policy.toPolicy? + = some (aps.filter (fun ap => satisfiedBound (Cedar.Slice.scopeAnalysis ap) req entities)) := by + intro cps + induction cps with + | nil => + intro aps _ hforall + cases hforall + simp + | cons hd tl ih => + intro aps hwf hforall + cases hforall with + | cons hhd htl => + rename_i ap aps' + have ihtl := ih aps' (fun p hp => hwf p (List.mem_cons_of_mem hd hp)) htl + have hsc : Cst.scopeAnalysis hd (hwf hd List.mem_cons_self) + = Cedar.Slice.scopeAnalysis ap := + translation_preserves_scopeAnalysis' hhd (hwf hd List.mem_cons_self) + cases hb : satisfiedBound (Cedar.Slice.scopeAnalysis ap) req entities + · have hF : (fun x : {x // x ∈ hd :: tl} => + if satisfiedBound (Cst.scopeAnalysis x.1 (hwf x.1 x.2)) req entities + then some x.1 else none) ⟨hd, List.mem_cons_self⟩ = none := by + simp [hsc, hb] + rw [List.attach_cons, + List.filterMap_cons_none (f := fun x : {x // x ∈ hd :: tl} => + if satisfiedBound (Cst.scopeAnalysis x.1 (hwf x.1 x.2)) req entities + then some x.1 else none) hF, + List.filterMap_map, List.filter_cons] + simp only [hb, Bool.false_eq_true, if_false] + exact ihtl + · have hF : (fun x : {x // x ∈ hd :: tl} => + if satisfiedBound (Cst.scopeAnalysis x.1 (hwf x.1 x.2)) req entities + then some x.1 else none) ⟨hd, List.mem_cons_self⟩ = some hd := by + simp [hsc, hb] + rw [List.attach_cons, + List.filterMap_cons_some (f := fun x : {x // x ∈ hd :: tl} => + if satisfiedBound (Cst.scopeAnalysis x.1 (hwf x.1 x.2)) req entities + then some x.1 else none) hF, + List.filterMap_map, List.filter_cons] + simp only [hb, if_true] + exact mapM_toPolicy?_cons hhd ihtl + +/-- The CST scope-based slice and the AST scope-based slice choose the same + policies: translating the CST slice yields exactly the AST slice of the + translated policy store. -/ +theorem cst_slice_chooses_same_policies' + {cps : Cst.Policies} {aps : Spec.Policies} + (req : Request) (entities : Entities) + (htrans : cps.toPolicies? = some aps) + (hwf : ∀ policy ∈ cps.ps, (prVars? policy).isSome) : + (Cst.BoundAnalysis.slice Cst.scopeAnalysis req entities cps hwf).toPolicies? + = some (Cedar.Slice.BoundAnalysis.slice Cedar.Slice.scopeAnalysis req entities aps) := by + have hforall := toPolicies?_forall₂ htrans + simp only [Cst.BoundAnalysis.slice, Cst.Policies.toPolicies?, + Cedar.Slice.BoundAnalysis.slice] + exact scope_slice_translate req entities cps.ps aps hwf hforall + +theorem cst_slice_chooses_same_policies + {cps : Cst.Policies} {aps : Spec.Policies} + (req : Request) (entities : Entities) + (htrans : cps.toPolicies? = some aps) : + ∃ hwf : ∀ policy ∈ cps.ps, (prVars? policy).isSome, + (Cst.BoundAnalysis.slice Cst.scopeAnalysis req entities cps hwf).toPolicies? + = some (Cedar.Slice.BoundAnalysis.slice Cedar.Slice.scopeAnalysis req entities aps) := by + have h := policies_translation_success_prVars_isSome' htrans + exists h + apply (cst_slice_chooses_same_policies' req entities htrans) + + +/-- From `Forall₂ R xs ys` and `y ∈ ys`, recover a related `x ∈ xs`. -/ +public theorem forall₂_exists_mem_right {α β : Type _} {R : α → β → Prop} + {xs : List α} {ys : List β} + (h : List.Forall₂ R xs ys) : ∀ {y}, y ∈ ys → ∃ x ∈ xs, R x y := by + induction h with + | nil => intro y hy; simp at hy + | @cons x y' xs' ys' hr _ ih => + intro y hy + rcases List.mem_cons.mp hy with heq | hmem + · subst heq; exact ⟨x, List.mem_cons_self, hr⟩ + · obtain ⟨x', hx'mem, hx'r⟩ := ih hmem + exact ⟨x', List.mem_cons_of_mem _ hx'mem, hx'r⟩ + +/-- From `Forall₂ R xs ys` and `x ∈ xs`, recover a related `y ∈ ys`. -/ +public theorem forall₂_exists_mem_left {α β : Type _} {R : α → β → Prop} + {xs : List α} {ys : List β} + (h : List.Forall₂ R xs ys) : ∀ {x}, x ∈ xs → ∃ y ∈ ys, R x y := by + induction h with + | nil => intro x hx; simp at hx + | @cons x' y' xs' ys' hr _ ih => + intro x hx + rcases List.mem_cons.mp hx with heq | hmem + · subst heq; exact ⟨y', List.mem_cons_self, hr⟩ + · obtain ⟨y'', hy''mem, hy''r⟩ := ih hmem + exact ⟨y'', List.mem_cons_of_mem _ hy''mem, hy''r⟩ + +/-- If every element of `xs` maps to `some`, then `mapM` succeeds. -/ +private theorem mapM_some_of_all_isSome {α β : Type _} {f : α → Option β} : + ∀ {xs : List α}, (∀ x ∈ xs, (f x).isSome) → ∃ ys, xs.mapM f = some ys := by + intro xs + induction xs with + | nil => intro _; exact ⟨[], by simp⟩ + | cons hd tl ih => + intro h + obtain ⟨b, hb⟩ := Option.isSome_iff_exists.mp (h hd List.mem_cons_self) + obtain ⟨bs, hbs⟩ := ih (fun x hx => h x (List.mem_cons_of_mem _ hx)) + exact ⟨b :: bs, by simp [List.mapM_cons, hb, hbs]⟩ + +/-- A subset of a translating policy store also translates. -/ +theorem slice_toPolicies?_isSome {slice policies : Cst.Policies} {aps : Spec.Policies} + (hsub : slice.ps ⊆ policies.ps) (haps : policies.toPolicies? = some aps) : + ∃ sps, slice.toPolicies? = some sps := by + have hfp := toPolicies?_forall₂ haps + simp only [Cst.Policies.toPolicies?] + apply mapM_some_of_all_isSome + intro cp hcp + obtain ⟨ap, _, hr⟩ := forall₂_exists_mem_left hfp (hsub hcp) + rw [Option.isSome_iff_exists]; exact ⟨ap, hr⟩ + + + +/-- Every policy kept by the CST bound-analysis slice is a member of the + original policy store. -/ +theorem cst_bound_slice_subset (ba : Cst.BoundAnalysis) (request : Request) + (entities : Entities) (policies : Cst.Policies) + (hwf : ∀ policy ∈ policies.ps, (prVars? policy).isSome) : + (Cst.BoundAnalysis.slice ba request entities policies hwf).ps ⊆ policies.ps := by + intro x hx + simp only [Cst.BoundAnalysis.slice, List.mem_filterMap] at hx + obtain ⟨⟨a, ha⟩, _, hF⟩ := hx + split at hF + · injection hF with h; exact h ▸ ha + · contradiction + +/-- If a policy's bound is satisfied, it is kept by the CST bound-analysis slice. -/ +theorem cst_bound_slice_kept (ba : Cst.BoundAnalysis) (request : Request) + (entities : Entities) (policies : Cst.Policies) + (hwf : ∀ policy ∈ policies.ps, (prVars? policy).isSome) + {policy : Cst.Policy} (hmem : policy ∈ policies.ps) + (hsat : satisfiedBound (ba policy (hwf policy hmem)) request entities) : + policy ∈ (Cst.BoundAnalysis.slice ba request entities policies hwf).ps := by + simp only [Cst.BoundAnalysis.slice, List.mem_filterMap] + exact ⟨⟨policy, hmem⟩, List.mem_attach _ _, by simp [hsat]⟩ + + +/-- A policy belonging to a store that translates also translates. -/ +theorem policy_toPolicy?_isSome_of_mem {policies : Cst.Policies} {policy : Cst.Policy} + (htrans : (policies.toPolicies?).isSome) (hmem : policy ∈ policies.ps) : + (policy.toPolicy?).isSome := by + obtain ⟨aps, haps⟩ := Option.isSome_iff_exists.mp htrans + obtain ⟨ap, _, hr⟩ := forall₂_exists_mem_left (toPolicies?_forall₂ haps) hmem + rw [Option.isSome_iff_exists]; exact ⟨ap, hr⟩ diff --git a/cedar-lean/Cedar/Thm/Frontend/Parser.lean b/cedar-lean/Cedar/Thm/Frontend/Parser.lean new file mode 100644 index 000000000..72126c525 --- /dev/null +++ b/cedar-lean/Cedar/Thm/Frontend/Parser.lean @@ -0,0 +1,74 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +import Cedar.Thm.Frontend.Parser.Strings + +/-! This file states and proves the main theorems about the Cedar parser's pure functions. -/ + +namespace Cedar.Frontend.Cst.Parser + +/-- `Nat.toHexChars` is equivalent to `Nat.toDigits 16` for values up to 4095. + This gives additional assurance that our custom implementation matches the stdlib. -/ +theorem toHexChars_eq_toDigits : + ∀ n : Fin 4096, Nat.toHexChars n.val = Nat.toDigits 16 n.val := by + native_decide + +/-- `Nat.toHexString` roundtrips through `String.asHexNat` for all values ≤ 0xFFFFFF. -/ +theorem String.asHexNat_toHexString (n : Nat) (h : n ≤ 0xFFFFFF) : + (Nat.toHexString n).asHexNat = .ok n := by + simp only [Nat.toHexString] + have hne : Nat.toHexChars n ≠ [] := by + unfold Nat.toHexChars + split + · exact List.cons_ne_nil _ _ + · next h0 => + intro heq + have hpos : n > 0 := by simp [BEq.beq] at h0; omega + have hlen := go_nonempty n hpos + rw [heq] at hlen; simp at hlen + have hlen : (Nat.toHexChars n).length ≤ 6 := by + unfold Nat.toHexChars + split + · simp + · exact go_length_le n h + rw [asHexNat_eq_hexFold _ hne hlen] + match hn : n with + | 0 => exact toHexChars_zero_roundtrip + | n + 1 => exact toHexChars_pos_roundtrip (n + 1) (by omega) + +/-- `classifyIdent` is a left inverse of `Ident.toString`. -/ +theorem classifyIdent_roundtrip (i : Ident) : + classifyIdent i.toString = i := by + cases i with + | idIdent s h => simp only [Ident.toString, classifyIdent, dif_neg h] + | _ => rfl + +/-- `Char.asHexNat` is injective on lowercase hex chars: + if two chars in '0'..'9' or 'a'..'f' map to the same value, they are equal. -/ +theorem Char.asHexNat_injective_lower (c₁ c₂ : Char) (n : Nat) + (h₁ : Char.asHexNat c₁ = .ok n) + (h₂ : Char.asHexNat c₂ = .ok n) + (hlc₁ : isLowerHex c₁) (hlc₂ : isLowerHex c₂) : + c₁ = c₂ := by + unfold Char.asHexNat at h₁ h₂ + simp only [Bool.and_eq_true, decide_eq_true_eq, Char.le_def, UInt32.le_iff_toNat_le] at h₁ h₂ + unfold isLowerHex at hlc₁ hlc₂ + have heq : c₁.toNat = c₂.toNat := by + rcases hlc₁ with ⟨lo₁, hi₁⟩ | ⟨lo₁, hi₁⟩ <;> rcases hlc₂ with ⟨lo₂, hi₂⟩ | ⟨lo₂, hi₂⟩ <;> + (split at h₁ <;> split at h₂ <;> simp_all <;> omega) + exact Char.eq_of_toNat_eq heq + +end Cedar.Frontend.Cst.Parser diff --git a/cedar-lean/Cedar/Thm/Frontend/Parser/Strings.lean b/cedar-lean/Cedar/Thm/Frontend/Parser/Strings.lean new file mode 100644 index 000000000..4a257aa07 --- /dev/null +++ b/cedar-lean/Cedar/Thm/Frontend/Parser/Strings.lean @@ -0,0 +1,189 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +import Cedar.Frontend.Parser +import Cedar.Frontend.Cst + +/-! This file contains lemmas for proving roundtrip properties of hex string conversion. -/ + +namespace Cedar.Frontend.Cst.Parser + +open Cedar.Frontend.Cst + +instance : DecidableEq (Except String Nat) := fun a b => + match a, b with + | .ok n, .ok m => if h : n = m then isTrue (by rw [h]) else isFalse (by intro h'; injection h'; contradiction) + | .error s, .error t => if h : s = t then isTrue (by rw [h]) else isFalse (by intro h'; injection h'; contradiction) + | .ok _, .error _ => isFalse (by intro h; injection h) + | .error _, .ok _ => isFalse (by intro h; injection h) + +/-- `Nat.digitChar n` for `n < 16` roundtrips through `Char.asHexNat`. -/ +theorem Char.asHexNat_digitChar (n : Nat) (h : n < 16) : + Char.asHexNat (Nat.digitChar n) = .ok n := by + match n, h with + | 0, _ | 1, _ | 2, _ | 3, _ | 4, _ | 5, _ | 6, _ | 7, _ | + 8, _ | 9, _ | 10, _ | 11, _ | 12, _ | 13, _ | 14, _ | 15, _ => + simp [Char.asHexNat, Nat.digitChar] + | n + 16, h => omega + +/-- The fold that `String.asHexNat` performs, extracted for reasoning. -/ +def hexFold (cs : List Char) (init : Except String Nat) : Except String Nat := + cs.foldl (fun acc c => do let v ← acc; let d ← c.asHexNat; .ok (v * 16 + d)) init + +theorem hexFold_nil (init : Except String Nat) : + hexFold [] init = init := rfl + +theorem hexFold_cons (c : Char) (cs : List Char) (init : Except String Nat) : + hexFold (c :: cs) init = hexFold cs (do let v ← init; let d ← c.asHexNat; .ok (v * 16 + d)) := by + simp [hexFold, List.foldl] + +theorem hexFold_ok_digit (cs : List Char) (v d : Nat) (hd : d < 16) : + hexFold (Nat.digitChar d :: cs) (.ok v) = hexFold cs (.ok (v * 16 + d)) := by + rw [hexFold_cons] + simp [bind, Except.bind, Char.asHexNat_digitChar d hd] + +/-- The generalized invariant: `hexFold (go n acc) (.ok 0) = hexFold acc (.ok n)` -/ +theorem go_hexFold (n : Nat) (acc : List Char) : + hexFold (Nat.toHexChars.go n acc) (.ok 0) = hexFold acc (.ok n) := by + match n with + | 0 => simp [Nat.toHexChars.go] + | n + 1 => + unfold Nat.toHexChars.go + simp only [] + have hmod : (n + 1) % 16 < 16 := Nat.mod_lt _ (by omega) + rw [go_hexFold ((n + 1) / 16) (Nat.digitChar ((n + 1) % 16) :: acc)] + rw [hexFold_ok_digit _ _ _ hmod] + have heq : (n + 1) / 16 * 16 + (n + 1) % 16 = n + 1 := by + have := Nat.div_add_mod (n + 1) 16; omega + rw [heq] +termination_by n + +/-- `toHexChars` for `n > 0` satisfies the roundtrip via hexFold. -/ +theorem toHexChars_pos_roundtrip (n : Nat) (hn : n > 0) : + hexFold (Nat.toHexChars n) (.ok 0) = .ok n := by + simp only [Nat.toHexChars] + have hne : (n == 0) = false := by simp [BEq.beq]; omega + rw [if_neg (by simp [hne])] + rw [go_hexFold] + simp [hexFold] + +/-- `toHexChars 0` roundtrips. -/ +theorem toHexChars_zero_roundtrip : + hexFold (Nat.toHexChars 0) (.ok 0) = .ok 0 := by + simp [Nat.toHexChars, hexFold, List.foldl, Char.asHexNat, bind, Except.bind] + +/-- Relate `String.asHexNat` to `hexFold`. -/ +theorem asHexNat_eq_hexFold (cs : List Char) (hne : cs ≠ []) (hlen : cs.length ≤ 6) : + (String.ofList cs).asHexNat = hexFold cs (.ok 0) := by + unfold String.asHexNat hexFold + have h1 : (String.ofList cs).isEmpty = false := by + cases cs with + | nil => exact absurd rfl hne + | cons c cs => + have hne' : String.ofList (c :: cs) ≠ "" := by + intro h + have := String.toList_ofList (l := c :: cs) + rw [h] at this; simp at this + exact Bool.eq_false_iff.mpr (mt String.isEmpty_iff.mp hne') + rw [if_neg (by rw [h1]; exact Bool.false_ne_true)] + rw [if_neg (by rw [String.length_ofList]; omega)] + rw [String.toList_ofList] + +/-- Length of `toHexChars.go` output. -/ +theorem go_length (n : Nat) (acc : List Char) : + (Nat.toHexChars.go n acc).length = (Nat.toHexChars.go n []).length + acc.length := by + match n with + | 0 => simp [Nat.toHexChars.go] + | n + 1 => + unfold Nat.toHexChars.go + simp only [] + rw [go_length ((n+1)/16) (Nat.digitChar ((n+1) % 16) :: acc)] + rw [go_length ((n+1)/16) [Nat.digitChar ((n+1) % 16)]] + simp [List.length] + omega +termination_by n + +public theorem go_nonempty (n : Nat) (hn : n > 0) : + (Nat.toHexChars.go n []).length ≥ 1 := by + match n with + | n + 1 => + unfold Nat.toHexChars.go + simp only [] + rw [go_length] + simp [List.length] + +public theorem go_length_le (n : Nat) (hn : n ≤ 0xFFFFFF) : + (Nat.toHexChars.go n []).length ≤ 6 := by + suffices ∀ (k : Nat) (m : Nat), m < 16^k → (Nat.toHexChars.go m []).length ≤ k from + this 6 n (by omega) + intro k + induction k with + | zero => intro m hm; simp at hm; subst hm; simp [Nat.toHexChars.go] + | succ k ih => + intro m hm + match m with + | 0 => simp [Nat.toHexChars.go] + | m + 1 => + unfold Nat.toHexChars.go + simp only [] + rw [go_length] + simp [List.length] + have hdiv : (m + 1) / 16 < 16 ^ k := by + have : (m + 1) / 16 < (16 ^ (k + 1)) / 16 := Nat.div_lt_div_of_lt_of_dvd (by omega) hm + simp [Nat.pow_succ] at this + exact this + exact ih _ hdiv + +----- classifyIdent / Ident.toString roundtrip ----- + +/-- `classifyIdent` is a left inverse of `Ident.toString` for keyword identifiers. -/ +theorem classifyIdent_toString_keyword (i : Cst.Ident) (h : ¬∃ s hs, i = .idIdent s hs) : + classifyIdent (Ident.toString i) = i := by + cases i with + | idIdent s hs => exact absurd ⟨s, hs, rfl⟩ h + | _ => rfl + +/-- `classifyIdent` roundtrips with `Ident.toString` when the string is not a keyword. -/ +theorem classifyIdent_toString_ident (s : String) + (h : s ∉ keywords) : + classifyIdent (Ident.toString (.idIdent s h)) = .idIdent s h := by + simp only [Ident.toString, classifyIdent, dif_neg h] + +/-- `Ident.toString` is a left inverse of `classifyIdent` for all Cedar keywords. -/ +theorem toString_classifyIdent_keyword (s : String) (h : s ∈ keywords) : + Ident.toString (classifyIdent s) = s := by + simp only [keywords, List.mem_cons, List.mem_nil_iff, or_false] at h + rcases h with h | h | h | h | h | h | h | h | h | h | h | h | h | h | h | h | h <;> + subst h <;> rfl + +/-- `Ident.toString` is a left inverse of `classifyIdent` for non-keyword identifiers. -/ +theorem toString_classifyIdent_ident (s : String) + (h : s ∉ keywords) : + Ident.toString (classifyIdent s) = s := by + simp only [classifyIdent, dif_neg h, Ident.toString] + +----- String.asHexNat injectivity ----- + + +/-- A lowercase hex char is one in '0'..'9' or 'a'..'f'. -/ +def isLowerHex (c : Char) : Prop := + (48 ≤ c.toNat ∧ c.toNat ≤ 57) ∨ (97 ≤ c.toNat ∧ c.toNat ≤ 102) + +/-- Two chars with the same `toNat` are equal. -/ +theorem Char.eq_of_toNat_eq {c₁ c₂ : Char} (h : c₁.toNat = c₂.toNat) : c₁ = c₂ := + Char.ext_iff.mpr (congrArg UInt32.ofBitVec (BitVec.eq_of_toNat_eq h)) + +end Cedar.Frontend.Cst.Parser diff --git a/cedar-lean/Cedar/Thm/Frontend/Translation/AuxComplete.lean b/cedar-lean/Cedar/Thm/Frontend/Translation/AuxComplete.lean new file mode 100644 index 000000000..d04948f85 --- /dev/null +++ b/cedar-lean/Cedar/Thm/Frontend/Translation/AuxComplete.lean @@ -0,0 +1,393 @@ +import Cedar.Spec +import Cedar.Frontend.Cst +import Cedar.Frontend.Cst.Semantics +import Cedar.Frontend.Cst.ToAst +import Cedar.Thm.Frontend.Translation.AuxSound +import Cedar.Thm.Data.List.Lemmas + +/-! +Auxiliary lemmas for the CST→AST translation *completeness* proofs +(`Cedar/Thm/Translation/ExprComplete.lean`): if a CST expression evaluates +without error, then its translation succeeds. + +These are the "list" and "record" shaped helpers, parameterised by a +per-element completeness hypothesis so they don't themselves recurse into the +expression grammar. +-/ + +namespace Cedar.Thm + +open Cedar.Data +open Cedar.Spec +open Cedar.Frontend + +/-- If a list of CST expressions all evaluate (the `Except` `mapM` is `.ok`), + and each translates whenever it evaluates, then the list translates. -/ +theorem list_eval_complete {req : Request} {es : Entities} : + ∀ (xs : List Cst.Expr) (vs : List Value), + xs.mapM (fun x => x.evaluate req es) = .ok vs → + (∀ x ∈ xs, ∀ v, x.evaluate req es = .ok v → ∃ ae, x.toAExpr? = some ae) → + ∃ aes, xs.mapM (fun x => x.toAExpr?) = some aes := by + intro xs + induction xs with + | nil => intro vs _ _; exact ⟨[], by simp⟩ + | cons hd tl ih => + intro vs hev hcomp + simp only [List.mapM_cons, bind, Except.bind] at hev + cases hhd : hd.evaluate req es with + | error e => rw [hhd] at hev; simp at hev + | ok vhd => + rw [hhd] at hev + cases htl : tl.mapM (fun x => x.evaluate req es) with + | error e => rw [htl] at hev; simp at hev + | ok vtl => + obtain ⟨ae_hd, hae_hd⟩ := hcomp hd List.mem_cons_self vhd hhd + obtain ⟨aes_tl, haes_tl⟩ := + ih vtl htl (fun x hx => hcomp x (List.mem_cons_of_mem _ hx)) + exact ⟨ae_hd :: aes_tl, by simp [List.mapM_cons, hae_hd, haes_tl]⟩ + +/-- If a record literal's key/value pairs all evaluate (the `Except` `mapM` is + `.ok`), and each value translates whenever it evaluates, then the record + translates (`rInitsToMap?` succeeds). Keys are handled by + `Cst.Expr.toAttr?_consistent`. -/ +theorem rInits_complete {req : Request} {es : Entities} : + ∀ (r : List Cst.RecInit) (avs : List (Attr × Value)), + r.mapM (fun ri => + match ri.attr.toAttr? with + | none => Except.error (Error.cstError CstError.stringError) + | some attr => do let val ← ri.value.evaluate req es; .ok (attr, val)) = .ok avs → + (∀ ri ∈ r, ∀ v, ri.value.evaluate req es = .ok v → ∃ ae, ri.value.toAExpr? = some ae) → + ∃ map, Cst.rInitsToMap? r = some map := by + intro r + induction r with + | nil => intro avs _ _; exact ⟨[], by simp [Cst.rInitsToMap?]⟩ + | cons ri rs ih => + intro avs hev hcomp + rw [List.mapM_ok_iff_forall₂] at hev + cases hev with + | cons hhd htl => + rename_i av_hd av_tl + cases hkey : ri.attr.toAttr? with + | none => simp [hkey] at hhd + | some attr => + cases hvalv : ri.value.evaluate req es with + | error e => simp [hkey, hvalv, bind, Except.bind] at hhd + | ok vval => + have hkey_t := Cst.Expr.toAttr?_consistent ri.attr + rw [hkey] at hkey_t + replace hkey_t := hkey_t.symm + rw [Option.bind_eq_some_iff] at hkey_t + obtain ⟨eos, heos, hattr⟩ := hkey_t + obtain ⟨vae, hvae⟩ := hcomp ri List.mem_cons_self vval hvalv + have htl' : rs.mapM (fun ri => + match ri.attr.toAttr? with + | none => Except.error (Error.cstError CstError.stringError) + | some attr => do let val ← ri.value.evaluate req es; .ok (attr, val)) = .ok av_tl := by + rw [List.mapM_ok_iff_forall₂]; exact htl + obtain ⟨mtl, hmtl⟩ := ih av_tl htl' (fun x hx => hcomp x (List.mem_cons_of_mem _ hx)) + exact ⟨(attr, vae) :: mtl, by simp [Cst.rInitsToMap?, heos, hattr, hvae, hmtl]⟩ + +/-- `toUnreservedString?` succeeds only on an (unreserved) `.idIdent`. -/ +private theorem toUnreservedString?_some {i : Cst.Ident} {s : String} + (h : Cst.Ident.toUnreservedString? i = some s) : ∃ hk, i = .idIdent s hk := by + cases i + case idIdent s' hk' => + simp only [Cst.Ident.toUnreservedString?] at h + split at h + · injection h with h'; subst h'; exact ⟨hk', rfl⟩ + · exact absurd h (by simp) + all_goals simp [Cst.Ident.toUnreservedString?] at h + +/-- Prepending a field accessor reduces through `memberAuxB`'s attribute branch + as long as the remaining accessors don't begin with a call. -/ +private theorem memberAuxB_field_cons (id : Cst.Ident) (l : List Cst.AstAccessor) (he : Expr) + (hnc : ∀ cargs t, l ≠ Cst.AstAccessor.call cargs :: t) : + Cst.memberAuxB he (.field id :: l) = Cst.memberAuxB (.getAttr he (Cst.Ident.toString id)) l := by + cases l with + | nil => simp [Cst.memberAuxB] + | cons a t => + cases a with + | call cargs => exact absurd rfl (hnc cargs t) + | field f => simp [Cst.memberAuxB] + | index s => simp [Cst.memberAuxB] + +/-- Core accessor-list completeness: if `Member.evalAccessors` succeeds on `accs` + (and each call-argument translates when it evaluates), then `accs` translates + via `toAstAccessor?`, the translation never begins with a call, and the + resulting accessor list is accepted by `memberAuxB` for any head expression. -/ +theorem evalAccessors_complete {req : Request} {es : Entities} + (accs : List Cst.MemAccess) (head v : Value) + (hev : Cst.Member.evalAccessors head accs req es = .ok v) + (hcomp : ∀ ce : Cst.Expr, sizeOf ce < sizeOf accs → + ∀ w, ce.evaluate req es = .ok w → ∃ ax, ce.toAExpr? = some ax) : + ∃ accs_ast, accs.mapM Cst.MemAccess.toAstAccessor? = some accs_ast ∧ + (∀ cargs t, accs_ast ≠ Cst.AstAccessor.call cargs :: t) ∧ + ∀ he : Expr, ∃ r, Cst.memberAuxB he accs_ast = some r := by + match accs, hev with + | [], _ => exact ⟨[], by simp, by simp, fun he => ⟨he, rfl⟩⟩ + | .call _ :: _, hev => simp [Cst.Member.evalAccessors] at hev + | .index ex :: rest, hev => + cases hex : Cst.Expr.toUnescapedStringLiteral? ex with + | none => simp [Cst.Member.evalAccessors, hex] at hev + | some attr => + simp only [Cst.Member.evalAccessors, hex] at hev + cases hga : getAttr head attr es with + | error e => simp [hga, bind, Except.bind] at hev + | ok v' => + simp only [hga, bind, Except.bind] at hev + obtain ⟨rest_ast, hrest_ast, _, hmemb⟩ := evalAccessors_complete rest v' v hev + (fun ce hsz w hcw => hcomp ce (by simp only [List.cons.sizeOf_spec]; omega) w hcw) + refine ⟨.index attr :: rest_ast, ?_, by simp, ?_⟩ + · simp [List.mapM_cons, Cst.MemAccess.toAstAccessor?, hex, hrest_ast] + · intro he + obtain ⟨r, hr⟩ := hmemb (Expr.getAttr he attr) + exact ⟨r, by simp only [Cst.memberAuxB]; exact hr⟩ + | .field i :: .call args :: rest, hev => + cases hi : Cst.Ident.toUnreservedString? i with + | none => simp [Cst.Member.evalAccessors, hi] at hev + | some m => + obtain ⟨hm_kw, hii⟩ := toUnreservedString?_some hi; subst hii + cases hop : Cst.String.toMethodOp? m with + | none => simp [Cst.Member.evalAccessors, hi, hop] at hev + | some op => + cases op with + | inl bop => + cases args with + | nil => simp [Cst.Member.evalAccessors, hi, hop] at hev + | cons arg rest_args => + cases rest_args with + | cons _ _ => simp [Cst.Member.evalAccessors, hi, hop] at hev + | nil => + simp only [Cst.Member.evalAccessors, hi, hop] at hev + cases harg : arg.evaluate req es with + | error e => rw [harg] at hev; simp [bind, Except.bind] at hev + | ok argVal => + rw [harg] at hev; simp only [bind, Except.bind] at hev + cases hap : apply₂ bop head argVal es with + | error e => rw [hap] at hev; simp at hev + | ok v' => + rw [hap] at hev + obtain ⟨a, ha⟩ := hcomp arg + (by simp only [List.cons.sizeOf_spec, Cst.MemAccess.call.sizeOf_spec, + List.nil.sizeOf_spec]; omega) argVal harg + obtain ⟨rest_ast, hrest_ast, _, hmemb⟩ := evalAccessors_complete rest v' v hev + (fun ce hsz w hcw => hcomp ce + (by simp only [List.cons.sizeOf_spec] at hsz ⊢; omega) w hcw) + refine ⟨.field (.idIdent m hm_kw) :: .call [a] :: rest_ast, ?_, by simp, ?_⟩ + · rw [List.mapM_cons, List.mapM_cons] + simp [Cst.MemAccess.toAstAccessor?, hi, Cst.Expr.toAExprs?, ha, hrest_ast] + · intro he + obtain ⟨r, hr⟩ := hmemb (Expr.binaryApp bop he a) + refine ⟨r, ?_⟩ + simp only [Cst.memberAuxB, Cst.Ident.toMeth?, hop, Cst.oneArg?] + exact hr + | inr uop => + cases args with + | cons _ _ => simp [Cst.Member.evalAccessors, hi, hop] at hev + | nil => + simp only [Cst.Member.evalAccessors, hi, hop, List.isEmpty_nil, if_true] at hev + cases hap : apply₁ uop head with + | error e => rw [hap] at hev; simp [bind, Except.bind] at hev + | ok v' => + rw [hap] at hev; simp only [bind, Except.bind] at hev + obtain ⟨rest_ast, hrest_ast, _, hmemb⟩ := evalAccessors_complete rest v' v hev + (fun ce hsz w hcw => hcomp ce + (by simp only [List.cons.sizeOf_spec] at hsz ⊢; omega) w hcw) + refine ⟨.field (.idIdent m hm_kw) :: .call [] :: rest_ast, ?_, by simp, ?_⟩ + · rw [List.mapM_cons, List.mapM_cons] + simp [Cst.MemAccess.toAstAccessor?, hi, Cst.Expr.toAExprs?, hrest_ast] + · intro he + obtain ⟨r, hr⟩ := hmemb (Expr.unaryApp uop he) + refine ⟨r, ?_⟩ + simp only [Cst.memberAuxB, Cst.Ident.toMeth?, hop, List.isEmpty_nil, if_true] + exact hr + | .field i :: [], hev => + cases hi : Cst.Ident.toUnreservedString? i with + | none => simp [Cst.Member.evalAccessors, hi] at hev + | some attr => + obtain ⟨hm_kw, hii⟩ := toUnreservedString?_some hi; subst hii + refine ⟨[.field (.idIdent attr hm_kw)], ?_, by simp, ?_⟩ + · simp [List.mapM_cons, Cst.MemAccess.toAstAccessor?, hi] + · intro he + exact ⟨Expr.getAttr he attr, by simp [Cst.memberAuxB, Cst.Ident.toString]⟩ + | .field i :: .field i2 :: rest, hev => + cases hi : Cst.Ident.toUnreservedString? i with + | none => simp [Cst.Member.evalAccessors, hi] at hev + | some attr => + obtain ⟨hm_kw, hii⟩ := toUnreservedString?_some hi; subst hii + simp only [Cst.Member.evalAccessors, hi] at hev + cases hga : getAttr head attr es with + | error e => simp [hga, bind, Except.bind] at hev + | ok v' => + simp only [hga, bind, Except.bind] at hev + have hev' : Cst.Member.evalAccessors v' (.field i2 :: rest) req es = .ok v := hev + obtain ⟨rest_ast, hrest_ast, hnc, hmemb⟩ := + evalAccessors_complete (.field i2 :: rest) v' v hev' + (fun ce hsz w hcw => hcomp ce (by simp only [List.cons.sizeOf_spec] at hsz ⊢; omega) w hcw) + refine ⟨.field (.idIdent attr hm_kw) :: rest_ast, ?_, by simp, ?_⟩ + · rw [List.mapM_cons]; simp [Cst.MemAccess.toAstAccessor?, hi, hrest_ast] + · intro he + obtain ⟨r, hr⟩ := hmemb (Expr.getAttr he attr) + refine ⟨r, ?_⟩ + rw [memberAuxB_field_cons _ rest_ast he hnc] + simpa [Cst.Ident.toString] using hr + | .field i :: .index ex :: rest, hev => + cases hi : Cst.Ident.toUnreservedString? i with + | none => simp [Cst.Member.evalAccessors, hi] at hev + | some attr => + obtain ⟨hm_kw, hii⟩ := toUnreservedString?_some hi; subst hii + have hstep : Cst.Member.evalAccessors head (.field (.idIdent attr hm_kw) :: .index ex :: rest) req es + = (do let hv ← getAttr head attr es; + Cst.Member.evalAccessors hv (.index ex :: rest) req es) := by + simp [Cst.Member.evalAccessors, hi] + rw [hstep] at hev + cases hga : getAttr head attr es with + | error e => rw [hga] at hev; simp [bind, Except.bind] at hev + | ok v' => + rw [hga] at hev; simp only [bind, Except.bind] at hev + obtain ⟨rest_ast, hrest_ast, hnc, hmemb⟩ := + evalAccessors_complete (.index ex :: rest) v' v hev + (fun ce hsz w hcw => hcomp ce (by simp only [List.cons.sizeOf_spec] at hsz ⊢; omega) w hcw) + refine ⟨.field (.idIdent attr hm_kw) :: rest_ast, ?_, by simp, ?_⟩ + · rw [List.mapM_cons]; simp [Cst.MemAccess.toAstAccessor?, hi, hrest_ast] + · intro he + obtain ⟨r, hr⟩ := hmemb (Expr.getAttr he attr) + refine ⟨r, ?_⟩ + rw [memberAuxB_field_cons _ rest_ast he hnc] + simpa [Cst.Ident.toString] using hr +termination_by sizeOf accs +decreasing_by + all_goals simp_wf + all_goals omega + +/-- Fold completeness for `MultExpr`: if `foldOps` succeeds and every operand + translates when it evaluates, then `foldExtended` succeeds (for any head). -/ +theorem multExprFoldExtended_complete {req : Request} {es : Entities} + (xs : List (Cst.MultOp × Cst.Unary)) (acc_v : Value) (acc_ast : Expr) (v : Value) + (hfold : Cst.MultExpr.foldOps acc_v xs req es = .ok v) + (hcomp : ∀ u : Cst.Unary, sizeOf u < sizeOf xs → + ∀ w, u.evaluate req es = .ok w → ∃ ax, u.toAExpr? = some ax) : + ∃ result, Cst.MultExpr.foldExtended acc_ast xs = some result := by + match xs, hfold with + | [], _ => exact ⟨acc_ast, by simp [Cst.MultExpr.foldExtended]⟩ + | (op, u) :: rest, hfold => + simp only [Cst.MultExpr.foldOps] at hfold + cases hu : u.evaluate req es with + | error e => rw [hu] at hfold; simp [bind, Except.bind] at hfold + | ok uv => + rw [hu] at hfold + cases op with + | mTimes => + simp only [bind, Except.bind] at hfold + cases hap : apply₂ .mul acc_v uv es with + | error e => rw [hap] at hfold; simp at hfold + | ok acc'' => + rw [hap] at hfold + obtain ⟨aval, haval⟩ := hcomp u + (by simp only [List.cons.sizeOf_spec, Prod.mk.sizeOf_spec]; omega) uv hu + obtain ⟨result, hresult⟩ := + multExprFoldExtended_complete rest acc'' (.binaryApp .mul acc_ast aval) v hfold + (fun u' hsz w hw => hcomp u' + (by simp only [List.cons.sizeOf_spec]; omega) w hw) + exact ⟨result, by simp [Cst.MultExpr.foldExtended, haval, hresult]⟩ + | mDivide => simp [bind, Except.bind] at hfold + | mMod => simp [bind, Except.bind] at hfold +termination_by sizeOf xs + +/-- Fold completeness for `AddExpr`: if `foldOps` succeeds and every operand + translates when it evaluates, then `foldExtended` succeeds (for any head). + Both `aPlus`/`aMinus` are accepted by the translator. -/ +theorem addExprFoldExtended_complete {req : Request} {es : Entities} + (xs : List (Cst.AddOp × Cst.MultExpr)) (acc_v : Value) (acc_ast : Expr) (v : Value) + (hfold : Cst.AddExpr.foldOps acc_v xs req es = .ok v) + (hcomp : ∀ m : Cst.MultExpr, sizeOf m < sizeOf xs → + ∀ w, m.evaluate req es = .ok w → ∃ ax, m.toAExpr? = some ax) : + ∃ result, Cst.AddExpr.foldExtended acc_ast xs = some result := by + match xs, hfold with + | [], _ => exact ⟨acc_ast, by simp [Cst.AddExpr.foldExtended]⟩ + | (op, m) :: rest, hfold => + simp only [Cst.AddExpr.foldOps] at hfold + cases hm : m.evaluate req es with + | error e => rw [hm] at hfold; simp at hfold + | ok mv => + rw [hm] at hfold + obtain ⟨aval, haval⟩ := hcomp m + (by simp only [List.cons.sizeOf_spec, Prod.mk.sizeOf_spec]; omega) mv hm + cases op with + | aPlus => + simp only [bind, Except.bind] at hfold + cases hap : apply₂ .add acc_v mv es with + | error e => rw [hap] at hfold; simp at hfold + | ok acc'' => + rw [hap] at hfold + obtain ⟨result, hresult⟩ := + addExprFoldExtended_complete rest acc'' (.binaryApp .add acc_ast aval) v hfold + (fun m' hsz w hw => hcomp m' (by simp only [List.cons.sizeOf_spec]; omega) w hw) + exact ⟨result, by simp [Cst.AddExpr.foldExtended, haval, hresult]⟩ + | aMinus => + simp only [bind, Except.bind] at hfold + cases hap : apply₂ .sub acc_v mv es with + | error e => rw [hap] at hfold; simp at hfold + | ok acc'' => + rw [hap] at hfold + obtain ⟨result, hresult⟩ := + addExprFoldExtended_complete rest acc'' (.binaryApp .sub acc_ast aval) v hfold + (fun m' hsz w hw => hcomp m' (by simp only [List.cons.sizeOf_spec]; omega) w hw) + exact ⟨result, by simp [Cst.AddExpr.foldExtended, haval, hresult]⟩ +termination_by sizeOf xs + +/-- If every conjunct of an `AndExpr`'s extended list translates, `foldExtended` + succeeds (for any head). Used in `AndExpr` completeness to discharge the + translatability guard recorded by the strengthened evaluator. -/ +theorem andExprFoldExtended_complete : + ∀ (xs : List Cst.Relation), (xs.all (fun r => r.toAExpr?.isSome) = true) → + ∀ (acc : Expr), ∃ result, Cst.AndExpr.foldExtended acc xs = some result := by + intro xs + induction xs with + | nil => intro _ acc; exact ⟨acc, by simp [Cst.AndExpr.foldExtended]⟩ + | cons rel rest ih => + intro hall acc + simp only [List.all_cons, Bool.and_eq_true] at hall + obtain ⟨hrel, hrest⟩ := hall + cases hrelE : rel.toAExpr? with + | none => rw [hrelE] at hrel; simp at hrel + | some aval => + obtain ⟨result, hresult⟩ := ih hrest (Cedar.Spec.Expr.and acc aval) + exact ⟨result, by simp [Cst.AndExpr.foldExtended, hrelE, hresult]⟩ + +/-- If every disjunct of an `OrExpr`'s extended list translates, `foldExtended` + succeeds (for any head). -/ +theorem orExprFoldExtended_complete : + ∀ (xs : List Cst.AndExpr), (xs.all (fun r => r.toAExpr?.isSome) = true) → + ∀ (acc : Expr), ∃ result, Cst.OrExpr.foldExtended acc xs = some result := by + intro xs + induction xs with + | nil => intro _ acc; exact ⟨acc, by simp [Cst.OrExpr.foldExtended]⟩ + | cons rel rest ih => + intro hall acc + simp only [List.all_cons, Bool.and_eq_true] at hall + obtain ⟨hrel, hrest⟩ := hall + cases hrelE : rel.toAExpr? with + | none => rw [hrelE] at hrel; simp at hrel + | some aval => + obtain ⟨result, hresult⟩ := ih hrest (Cedar.Spec.Expr.or acc aval) + exact ⟨result, by simp [Cst.OrExpr.foldExtended, hrelE, hresult]⟩ + +-- If a CST policy can be evaluated without error then scope extract will succeed +theorem extractScope_complete + (cp : Cst.Policy) (req : Request) (es : Entities) : + ¬ Cst.hasError cp req es → + ∃ trip, match cp with + | .policy p => Cst.extractScope? p.vars = some trip := by + intro hne + cases cp with + | policy p => + cases h : Cst.extractScope? p.vars with + | none => + exfalso + apply hne + have hpn : p.toPolicy? = none := by simp [Cst.PolicyImpl.toPolicy?, h] + simp only [Cst.hasError, hpn, Option.isNone_none, if_true] + | some trip => exact ⟨trip, h⟩ + +end Cedar.Thm diff --git a/cedar-lean/Cedar/Thm/Frontend/Translation/AuxSound.lean b/cedar-lean/Cedar/Thm/Frontend/Translation/AuxSound.lean new file mode 100644 index 000000000..cfc90f698 --- /dev/null +++ b/cedar-lean/Cedar/Thm/Frontend/Translation/AuxSound.lean @@ -0,0 +1,2646 @@ +import Cedar.Spec +import Cedar.Frontend.Cst +import Cedar.Frontend.Cst.Semantics +import Cedar.Frontend.Cst.ToAst +import Cedar.Thm.Data.List.Lemmas + +namespace Cedar.Thm + +open Cedar.Data +open Cedar.Spec +open Cedar.Frontend + + +/-- If `toExtFun?` succeeds on a string, that string is a function name. -/ +theorem toExtFun?_some_isFunctionName {s : String} {xfn : ExtFun} + (h : Cst.String.toExtFun? s = some xfn) : + Cst.String.isFunctionName? s = true := by + simp only [Cst.String.toExtFun?] at h + split at h <;> simp_all [Cst.String.isFunctionName?] + +/- For Primary -/ + +theorem Cst.Ident.toUnrestrictedString?_eq_toString + {i : Cst.Ident} {s : String} : + Cst.Ident.toUnrestrictedString? i = some s → + s = Cst.Ident.toString i := by + cases i <;> intro h <;> + simp_all [Cst.Ident.toUnrestrictedString?, Cst.Ident.toUnrestrictedString?, + Cst.Ident.toString] + +/-- If `mapM` over `toUnrestrictedString?` succeeds, the result equals `map toString`. -/ +theorem mapM_toUnrestrictedString?_eq_map + {l : List Cst.Ident} {result : List String} : + l.mapM Cst.Ident.toUnrestrictedString? = some result → + result = l.map Cst.Ident.toString := by + induction l generalizing result with + | nil => + intro h + simp [List.mapM, List.mapM.loop] at h + simp [← h] + | cons hd tl ih => + intro h + simp [List.mapM_cons, Option.bind_eq_some_iff] at h + obtain ⟨s, hs, rest, hrest, heq⟩ := h + simp [List.map, ← heq] + exact ⟨Cst.Ident.toUnrestrictedString?_eq_toString hs, ih hrest⟩ + +/-- `toAName?` produces the same `Spec.Name` the evaluator builds. -/ +theorem Cst.Name.toAName?_agrees + {n : Cst.Name} {an : Spec.Name} : + n.toAName? = some an → + an = { id := n.name.toString, + path := n.path.map Cst.Ident.toString } := by + intro h + simp [Cst.Name.toAName?, Cst.Name.toAName?, Option.bind_eq_some_iff] at h + obtain ⟨id, hid, path, hpath, han⟩ := h + rw [← han]; congr 1 + · exact Cst.Ident.toUnrestrictedString?_eq_toString hid + · exact mapM_toUnrestrictedString?_eq_map hpath + +theorem Cst.Name.toVar?_agrees + {n : Cst.Name} {v : Var} : + n.toVar? = some v → + n.path = [] ∧ + match v with + | .principal => n.name = Cst.Ident.idPrincipal + | .action => n.name = Cst.Ident.idAction + | .resource => n.name = Cst.Ident.idResource + | .context => n.name = Cst.Ident.idContext := by + intro h + simp [Cst.Name.toVar?] at h + obtain ⟨hpath, hname⟩ := h + refine ⟨hpath, ?_⟩ + cases hn : n.name <;> rw [hn] at hname <;> simp at hname <;> + cases v <;> simp_all + +/- For Member -/ + + +/- For Unary -/ + +theorem bangN_evaluate_error (e : Expr) (n : Nat) (req : Request) (es : Entities) (err : Error) : + evaluate e req es = .error err → + evaluate (Cst.bangN e n) req es = .error err := by + induction n generalizing e with + | zero => + intro he + rw [Cst.bangN]; simp; exact he + | succ n ih => + intro he + rw [Cst.bangN]; simp + apply ih (.unaryApp .not e) + simp [evaluate, he, bind, Except.bind] + +theorem bangN_evaluate + (e : Expr) (n : Nat) (req : Request) (es : Entities) (b : Bool) : + evaluate e req es = .ok (.prim (.bool b)) → + evaluate (Cst.bangN e n) req es = + if n%2 == 0 then .ok (.prim (.bool b)) else .ok (.prim (.bool !b)) := by + intro he + induction n generalizing e b with + | zero => simp [Cst.bangN]; exact he + | succ n ih => + rw [Cst.bangN]; simp + have hnot : evaluate (Expr.unaryApp UnaryOp.not e) req es = .ok (.prim (.bool !b)) := by + simp [evaluate, he, bind, Except.bind, apply₁] + rw [ih (Expr.unaryApp UnaryOp.not e) (!b) hnot] + rcases Nat.mod_two_eq_zero_or_one n with hn | hn + · -- n even, n+1 odd + have h1 : (n % 2 == 0) = true := by simp [hn] + simp [h1]; omega + · -- n odd, n+1 even + have h1 : (n % 2 == 0) = false := by simp [hn] + simp [h1]; omega + +theorem bangN_evaluate_nonBool + (e : Expr) (n : Nat) (req : Request) (es : Entities) (v : Value) : + evaluate e req es = .ok v → + (∀ b, v ≠ .prim (.bool b)) → + n > 0 → + evaluate (Cst.bangN e n) req es = .error .typeError := by + intro he hnb hpos + cases n with + | zero => omega + | succ k => + rw [Cst.bangN]; simp + apply bangN_evaluate_error (.unaryApp .not e) k req es .typeError + simp [evaluate, he, bind, Except.bind] + cases v with + | prim p => + cases p with + | bool b => exact absurd rfl (hnb b) + | _ => simp [apply₁] + | _ => simp [apply₁] + +theorem bangN_evaluate_ok + (e : Expr) (n : Nat) (req : Request) (es : Entities) (v : Value) : + evaluate e req es = .ok v → + evaluate (Cst.bangN e n) req es = ( + if n == 0 then .ok v + else match v with + | .prim (.bool b) => + if n % 2 == 0 then .ok (.prim (.bool b)) else .ok (.prim (.bool !b)) + | _ => .error .typeError) := by + intro hev + cases hn : n with + | zero => + simp [Cst.bangN, hev] + | succ k => + cases v with + | prim p => + cases p with + | bool b => + rw [bangN_evaluate e (k+1) req es b hev] + simp + | int _ | string _ | entityUID _ => + rw [bangN_evaluate_nonBool e (k+1) req es _ hev + (by intro b h; cases h) (by omega)] + simp + | set _ | record _ | ext _ => + rw [bangN_evaluate_nonBool e (k+1) req es _ hev + (by intro b h; cases h) (by omega)] + simp + +theorem bangN_evaluate_general + (e : Expr) (n : Nat) (req : Request) (es : Entities) : + evaluate (Cst.bangN e n) req es = (match evaluate e req es with + | .error err => .error err + | .ok v => + if n == 0 then .ok v + else match v with + | .prim (.bool b) => + if n % 2 == 0 then .ok (.prim (.bool b)) else .ok (.prim (.bool !b)) + | _ => .error .typeError) := by + cases hev : evaluate e req es with + | error err => + rw [bangN_evaluate_error e n req es err hev] + | ok v => + rw [bangN_evaluate_ok e n req es v hev] + +theorem dashN_evaluate_error (e : Expr) (n : Nat) (req : Request) (es : Entities) (err : Error) : + evaluate e req es = .error err → + evaluate (Cst.dashN e n) req es = .error err := by + induction n generalizing e with + | zero => + intro he + rw [Cst.dashN]; simp; exact he + | succ n ih => + intro he + rw [Cst.dashN]; simp + apply ih (.unaryApp .neg e) + simp [evaluate, he, bind, Except.bind] + +theorem dashN_evaluate_nonInt + (e : Expr) (n : Nat) (req : Request) (es : Entities) (v : Value) : + evaluate e req es = .ok v → + (∀ i, v ≠ .prim (.int i)) → + n > 0 → + evaluate (Cst.dashN e n) req es = .error .typeError := by + intro he hni hpos + cases n with + | zero => omega + | succ k => + rw [Cst.dashN]; simp + apply dashN_evaluate_error (.unaryApp .neg e) k req es .typeError + simp [evaluate, he, bind, Except.bind] + cases v with + | prim p => + cases p with + | int i => exact absurd rfl (hni i) + | _ => simp [apply₁] + | _ => simp [apply₁] + +/-- Helper: `(Int64.ofInt k).toInt = k` when `k` is in the `Int64` range. -/ +private theorem toInt_ofInt_of_range {k : Int} (h : Int64.MIN ≤ k ∧ k ≤ Int64.MAX) : + (Int64.ofInt k).toInt = k := by + have h1 : -2^63 ≤ k := by simp [Int64.MIN] at h; omega + have h2 : k < 2^63 := by simp [Int64.MAX] at h; omega + show BitVec.toInt (BitVec.ofInt 64 k) = k + rw [BitVec.toInt_ofInt] + exact Int.bmod_eq_of_le h1 h2 + +/-- Helper: if `Int64.ofInt? k = some v`, then `v.toInt = k`. -/ +private theorem toInt_of_ofInt? {k : Int} {v : Int64} + (h : Int64.ofInt? k = some v) : v.toInt = k := by + have hrange : Int64.MIN ≤ k ∧ k ≤ Int64.MAX := by + by_contra hnr + have : Int64.ofInt? k = none := by + apply Int64.ofInt?_none_iff.mp + by_cases hlo : Int64.MIN ≤ k + · right; by_contra hhi; apply hnr; exact ⟨hlo, by omega⟩ + · left; omega + rw [this] at h; cases h + have hsome : Int64.ofInt? k = some (Int64.ofInt k) := Int64.ofInt?_some_iff.mp hrange + rw [hsome] at h; injection h with hv + rw [← hv] + exact toInt_ofInt_of_range hrange + +/-- Double negation on `Int64`: if `i.neg? = some j` then `j.neg? = some i`. -/ +theorem Int64.neg?_neg? {i j : Int64} : + i.neg? = some j → j.neg? = some i := by + intro h + rw [Int64.neg?] at h + have hj : j.toInt = -i.toInt := toInt_of_ofInt? h + rw [Int64.neg?, hj] + rw [show -(-i.toInt) = i.toInt from by omega] + exact Int64.ofInt?_toInt i + +/-- `dashN` on an int. Note: when `i = Int64.MIN` (so `i.neg? = none`), the + AST iterates `apply₁ .neg` and errors on the first step — regardless of + whether the total count is even or odd. So the `i.neg? = none` arm here + short-circuits *before* the parity check. -/ +theorem dashN_evaluate_int + (e : Expr) (n : Nat) (req : Request) (es : Entities) (i : Int64) : + evaluate e req es = .ok (.prim (.int i)) → + evaluate (Cst.dashN e n) req es = + (if n == 0 then .ok (.prim (.int i)) + else match i.neg? with + | none => .error .arithBoundsError + | some j => + if n % 2 == 0 then .ok (.prim (.int i)) + else .ok (.prim (.int j))) := by + intro he + induction n generalizing e i with + | zero => simp [Cst.dashN]; exact he + | succ n ih => + rw [Cst.dashN]; simp + cases hneg : i.neg? with + | none => + have hev_err : evaluate (Expr.unaryApp UnaryOp.neg e) req es = .error .arithBoundsError := by + simp [evaluate, he, bind, Except.bind, apply₁, intOrErr, hneg] + rw [dashN_evaluate_error (Expr.unaryApp UnaryOp.neg e) n req es .arithBoundsError hev_err] + | some j => + have hev_ok : evaluate (Expr.unaryApp UnaryOp.neg e) req es = .ok (.prim (.int j)) := by + simp [evaluate, he, bind, Except.bind, apply₁, intOrErr, hneg] + rw [ih (.unaryApp .neg e) j hev_ok] + have hjneg : j.neg? = some i := Int64.neg?_neg? hneg + rw [hjneg] + rcases Nat.mod_two_eq_zero_or_one n with hn | hn + · -- n even ⇒ n+1 odd + have h1 : (n % 2 == 0) = true := by simp [hn] + have h2 : (n + 1) % 2 ≠ 0 := by simp [Nat.add_mod, hn] + simp [h1, h2] + · -- n odd ⇒ n+1 even + have h1 : (n % 2 == 0) = false := by simp [hn] + have h2 : (n + 1) % 2 = 0 := by simp [Nat.add_mod, hn] + have h3 : n ≠ 0 := by intro h; rw [h] at hn; simp at hn + simp [h1, h2, h3] + +theorem dashN_evaluate_ok + (e : Expr) (n : Nat) (req : Request) (es : Entities) (v : Value) : + evaluate e req es = .ok v → + evaluate (Cst.dashN e n) req es = ( + if n == 0 then .ok v + else match v with + | .prim (.int i) => + match i.neg? with + | none => .error .arithBoundsError + | some j => + if n % 2 == 0 then .ok (.prim (.int i)) + else .ok (.prim (.int j)) + | _ => .error .typeError) := by + intro hev + cases hn : n with + | zero => simp [Cst.dashN, hev] + | succ k => + cases v with + | prim p => + cases p with + | int i => + rw [dashN_evaluate_int e (k+1) req es i hev] + | bool _ | string _ | entityUID _ => + rw [dashN_evaluate_nonInt e (k+1) req es _ hev + (by intro i h; cases h) (by omega)] + simp + | set _ | record _ | ext _ => + rw [dashN_evaluate_nonInt e (k+1) req es _ hev + (by intro i h; cases h) (by omega)] + simp + +/-- Fully-unified `dashN` evaluation. NOTE: the CST evaluator's non-`liNum` + `nDash` arm in `CstSemantics.lean` will need to validate `i.neg?` *before* + the parity shortcut to match this spec — otherwise it diverges on + `Int64.MIN` inputs with even count. -/ +theorem dashN_evaluate_general + (e : Expr) (n : Nat) (req : Request) (es : Entities) : + evaluate (Cst.dashN e n) req es = (match evaluate e req es with + | .error err => .error err + | .ok v => + if n == 0 then .ok v + else match v with + | .prim (.int i) => + match i.neg? with + | none => .error .arithBoundsError + | some j => + if n % 2 == 0 then .ok (.prim (.int i)) + else .ok (.prim (.int j)) + | _ => .error .typeError) := by + cases hev : evaluate e req es with + | error err => + rw [dashN_evaluate_error e n req es err hev] + | ok v => + rw [dashN_evaluate_ok e n req es v hev] + +/- For Relation -/ + +/-- `Cst.constructExprRel op e₁ e₂` and the applied relational op evaluate equally. -/ +theorem constructExprRel_applyRelOp_eq + (op : Cst.RelOp) (e₁ e₂ : Expr) (req : Request) (es : Entities) + (v₁ v₂ : Value) : + evaluate e₁ req es = .ok v₁ → + evaluate e₂ req es = .ok v₂ → + evaluate (Cst.constructExprRel op e₁ e₂) req es = Cst.applyRelOp op v₁ v₂ es := by + intro he₁ he₂ + cases op <;> + simp [Cst.constructExprRel, Cst.applyRelOp, evaluate, he₁, he₂, + bind, Except.bind] + +/-- Collapse the `String ⊕ List String` shape from the translator's `toHasRhs?` + into a flat `List String`, treating `.inl f` as the singleton `[f]`. -/ +def hasRhsToList : String ⊕ List String → List String + | .inl f => [f] + | .inr fs => fs + +/-- Helper: `fieldChain?` and `constructAttrsAux?` are the same function + (both filter via `toUnreservedId?`/`toUnreservedString?` on `.field` accessors, + rejecting `.index`). -/ +theorem fieldChain?_eq_constructAttrsAux? + (xs : List Cst.MemAccess) : + Cst.fieldChain? xs = Cst.constructAttrsAux? xs := by + induction xs with + | nil => rfl + | cons hd tl ih => + cases hd with + | field id => + simp [Cst.fieldChain?, Cst.constructAttrsAux?, ih] + rfl + | index e => + simp [Cst.fieldChain?, Cst.constructAttrsAux?] + | call args => + simp [Cst.fieldChain?, Cst.constructAttrsAux?] + +/-- For the `rHas` case: `Cst.AddExpr.toHasRhs?` (translation) and `Cst.AddExpr.toAttrs?` + (evaluation) produce identical attribute lists when collapsed via `hasRhsToList`. + + With the evaluator strengthened to use `toUnreservedId?` (mismatch 2) and + `unescape?` (mismatch 3), the only structural difference is the `Sum` vs `List` + output type, which `hasRhsToList` bridges. -/ +theorem addExpr_toHasRhs_toAttrs_agrees + {e : Cst.AddExpr} {rhs : String ⊕ List String} : + e.toHasRhs? = some rhs → + e.toAttrs? = some (hasRhsToList rhs) := by + intro hrhs + simp [Cst.AddExpr.toHasRhs?] at hrhs + obtain ⟨⟨⟨he, hm⟩, hu⟩, hbody⟩ := hrhs + simp [Cst.AddExpr.toAttrs?, he, hm, hu] + match hmi : e.initial.initial.item.item with + | .literal lit => + rw [hmi] at hbody + cases lit with + | liTrue => + simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?] at hbody + | liFalse => + simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?] at hbody + | liNum n => + simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?, + Option.bind_eq_some_iff] at hbody + obtain ⟨a, ⟨_, _, ha⟩, hmatch⟩ := hbody + rw [← ha] at hmatch + simp at hmatch + | liStr s => + simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?] at hbody + cases haccess : e.initial.initial.item.access with + | nil => + rw [haccess] at hbody + simp at hbody + cases hunesc : Cst.unescape? s with + | none => rw [hunesc] at hbody; simp at hbody + | some s' => + rw [hunesc] at hbody + simp at hbody + rw [← hbody] + simp [hasRhsToList, Cst.fieldChain?, hunesc] + | cons hd tl => + rw [haccess] at hbody + cases hd with + | field id => simp at hbody + | index e' => simp at hbody + | call args => simp at hbody + | .name n => + rw [hmi] at hbody + simp [Cst.Primary.toExprOrSpecial?] at hbody + obtain ⟨np, nname⟩ := n + cases hvar : (Cst.Name.toVar? ⟨np, nname⟩) with + | some v => + rw [hvar] at hbody + simp [Option.map_eq_some_iff] at hbody + obtain ⟨attrs, hattrs, hrhsEq⟩ := hbody + have hagree := Cst.Name.toVar?_agrees hvar + have hpath : np = [] := hagree.1 + have hname := hagree.2 + simp [Cst.constructAttrs?, Option.bind_eq_some_iff] at hattrs + obtain ⟨tail, htail, hattrsEq⟩ := hattrs + subst hpath + cases v with + | principal => + simp at hname; subst hname + simp [fieldChain?_eq_constructAttrsAux?, htail] + rw [← hrhsEq] + simp [hasRhsToList, ← hattrsEq, Cst.Ident.toHasHead?, Cst.varToString] + | action => + simp at hname; subst hname + simp [fieldChain?_eq_constructAttrsAux?, htail] + rw [← hrhsEq] + simp [hasRhsToList, ← hattrsEq, Cst.Ident.toHasHead?, Cst.varToString] + | resource => + simp at hname; subst hname + simp [fieldChain?_eq_constructAttrsAux?, htail] + rw [← hrhsEq] + simp [hasRhsToList, ← hattrsEq, Cst.Ident.toHasHead?, Cst.varToString] + | context => + simp at hname; subst hname + simp [fieldChain?_eq_constructAttrsAux?, htail] + rw [← hrhsEq] + simp [hasRhsToList, ← hattrsEq, Cst.Ident.toHasHead?, Cst.varToString] + | none => + rw [hvar] at hbody + cases han : (⟨np, nname⟩ : Cst.Name).toAName? with + | none => rw [han] at hbody; simp at hbody + | some an => + rw [han] at hbody + simp [Option.bind_eq_some_iff, Option.map_eq_some_iff] at hbody + obtain ⟨hp, first, hfirst, attrs, hattrs, hrhseq⟩ := hbody + have han_eq := Cst.Name.toAName?_agrees han + have hnpath : np = [] := by + rw [han_eq] at hp; simp at hp; exact hp + subst hnpath + rw [han_eq] at hfirst + simp at hfirst + cases hname : nname with + | idIdent s hs_kw => + rw [hname] at hfirst + simp [Cst.Ident.toString] at hfirst + have hs_eq_and_unreserved : s = first ∧ Cst.Unreserved? s = true := by + simp [String.toUnreservedId?, Cst.Unreserved?] at hfirst ⊢ + split at hfirst <;> rename_i heq + all_goals (simp_all) + obtain ⟨hs_first, hs_unreserved⟩ := hs_eq_and_unreserved + simp [Cst.constructAttrs?, Option.bind_eq_some_iff] at hattrs + obtain ⟨tail, htail, hattrs_eq2⟩ := hattrs + simp [fieldChain?_eq_constructAttrsAux?, htail] + rw [← hrhseq] + simp [hasRhsToList, Cst.Ident.toHasHead?, hs_unreserved, + ← hs_first, ← hattrs_eq2] + | idPrincipal | idAction | idResource | idContext + | idTrue | idFalse | idPermit | idForbid + | idWhen | idUnless | idIn | idHas | idLike | idIs + | idIf | idThen | idElse => + rw [hname] at hfirst + simp [Cst.Ident.toString, String.toUnreservedId?] at hfirst + | .ref r => + rw [hmi] at hbody; simp at hbody + | .expr e' => + rw [hmi] at hbody; simp at hbody + | .eList es' => + rw [hmi] at hbody; simp at hbody + | .rInits r => + rw [hmi] at hbody; simp at hbody + | .slot _ => + rw [hmi] at hbody; simp at hbody +theorem fieldChain?_eq_nil {access : List Cst.MemAccess} : + Cst.fieldChain? access = some [] → access = [] := by + intro h + cases access with + | nil => rfl + | cons hd tl => + cases hd with + | field id => + simp [Cst.fieldChain?, Option.bind_eq_some_iff] at h + | index _ => simp [Cst.fieldChain?] at h + | call _ => simp [Cst.fieldChain?] at h + +/-- Converse direction (eval ⟹ translate) for `rHas`: if the evaluator's + `toAttrs?` succeeds, then the translator's `toHasRhs?` also succeeds. Both + accept exactly the same bare field-chain shapes: the evaluator was + strengthened to use `toHasHead?`/`toUnreservedId?`/`unescape?`, and + `fieldChain? = Cst.constructAttrsAux?`. -/ +theorem addExpr_toAttrs_toHasRhs {e : Cst.AddExpr} {attrs : List Attr} : + e.toAttrs? = some attrs → + ∃ rhs, e.toHasRhs? = some rhs := by + intro h + obtain ⟨⟨⟨op, ⟨prim, access⟩⟩, mext⟩, ext⟩ := e + simp only [Cst.AddExpr.toAttrs?] at h + cases ext with + | cons _ _ => simp at h + | nil => + cases mext with + | cons _ _ => simp at h + | nil => + cases op with + | some o => simp at h + | none => + cases hfc : Cst.fieldChain? access with + | none => rw [hfc] at h; simp at h + | some fields => + rw [hfc] at h + have hcaeq : Cst.constructAttrsAux? access = some fields := by + rw [← fieldChain?_eq_constructAttrsAux?]; exact hfc + cases prim with + | literal lit => + cases lit with + | liStr s => + cases hfe : fields.isEmpty with + | false => simp [hfe] at h + | true => + have hfields : fields = [] := by simpa using hfe + have hacc : access = [] := fieldChain?_eq_nil (hfields ▸ hfc) + subst hacc + cases hun : Cst.unescape? s with + | none => simp [hfe, hun] at h + | some s' => + exact ⟨.inl s', by + simp [Cst.AddExpr.toHasRhs?, Cst.Primary.toExprOrSpecial?, + Cst.Literal.toExprOrSpecial?, hun]⟩ + | liTrue | liFalse | liNum _ => simp at h + | name n => + obtain ⟨np, nname⟩ := n + cases np with + | cons _ _ => simp at h + | nil => + cases hhh : Cst.Ident.toHasHead? nname with + | none => simp [hhh] at h + | some idStr => + cases nname with + | idPrincipal => + exact ⟨.inr ("principal" :: fields), by + simp [Cst.AddExpr.toHasRhs?, Cst.Primary.toExprOrSpecial?, + Cst.Name.toVar?, Cst.varToString, Cst.constructAttrs?, hcaeq]⟩ + | idAction => + exact ⟨.inr ("action" :: fields), by + simp [Cst.AddExpr.toHasRhs?, Cst.Primary.toExprOrSpecial?, + Cst.Name.toVar?, Cst.varToString, Cst.constructAttrs?, hcaeq]⟩ + | idResource => + exact ⟨.inr ("resource" :: fields), by + simp [Cst.AddExpr.toHasRhs?, Cst.Primary.toExprOrSpecial?, + Cst.Name.toVar?, Cst.varToString, Cst.constructAttrs?, hcaeq]⟩ + | idContext => + exact ⟨.inr ("context" :: fields), by + simp [Cst.AddExpr.toHasRhs?, Cst.Primary.toExprOrSpecial?, + Cst.Name.toVar?, Cst.varToString, Cst.constructAttrs?, hcaeq]⟩ + | idIdent s hs_kw => + simp only [Cst.Ident.toHasHead?] at hhh + split at hhh + · rename_i hunres + have htus : String.toUnreservedId? s = some s := by + simp only [String.toUnreservedId?] + simp only [Cst.Unreserved?] at hunres + split <;> simp_all + refine ⟨.inr (s :: fields), ?_⟩ + simp [Cst.AddExpr.toHasRhs?, Cst.Primary.toExprOrSpecial?, + Cst.Name.toVar?, Cst.Name.toAName?, + Cst.Name.toAName?, + Cst.Ident.toUnrestrictedString?, + htus, Cst.constructAttrs?, hcaeq] + · simp at hhh + | idTrue | idFalse | idPermit | idForbid | idWhen | idUnless + | idIn | idHas | idLike | idIs | idIf | idThen | idElse => + simp [Cst.Ident.toHasHead?] at hhh + | ref _ | expr _ | slot _ | eList _ | rInits _ => simp at h +/-- `toAttrs?` always produces a non-empty list when it succeeds: the result is + either `[unescaped_lit]` or `head :: fields`. -/ +theorem toAttrs?_nonempty {e : Cst.AddExpr} {fs : List Attr} : + e.toAttrs? = some fs → fs ≠ [] := by + intro hattrs + simp only [Cst.AddExpr.toAttrs?] at hattrs + split at hattrs; · simp at hattrs + split at hattrs; · simp at hattrs + split at hattrs; · simp at hattrs + split at hattrs; · simp at hattrs + split at hattrs + · split at hattrs + · simp [Option.map_eq_some_iff] at hattrs + obtain ⟨_, _, hattrs⟩ := hattrs; rw [← hattrs]; simp + · simp at hattrs + · simp at hattrs + · split at hattrs + · simp at hattrs; rw [← hattrs]; simp + · simp at hattrs + · simp at hattrs + · simp at hattrs + +/-- Non-emptiness: `toHasRhs?` always produces a non-empty list when collapsed. + Used to discharge the evaluator's `some []` arm as vacuous. -/ +theorem hasRhsToList_nonempty {rhs : String ⊕ List String} + {e : Cst.AddExpr} : + e.toHasRhs? = some rhs → + hasRhsToList rhs ≠ [] := by + intro hrhs + -- The collapsed list `hasRhsToList rhs` equals `e.toAttrs?`, which is always + -- non-empty by `toAttrs?_nonempty`. + have hattrs := addExpr_toHasRhs_toAttrs_agrees hrhs + exact toAttrs?_nonempty hattrs + +/-- `hasAttr` always returns a Bool-valued `Value` on success. -/ +private theorem hasAttr_isBool {v : Value} {a : Attr} {es : Entities} {r : Value} : + hasAttr v a es = .ok r → ∃ b, r = .prim (.bool b) := by + intro h + simp [hasAttr, bind, Except.bind] at h + split at h + case h_1 => simp at h + all_goals (injection h with hr; rw [← hr]; exact ⟨_, rfl⟩) + +/-- `rHasChain` always returns a Bool-valued `Value` on success. -/ +private theorem rHasChain_isBool + (v : Value) (a : Attr) (as : List Attr) (es : Entities) : + ∀ r, Cst.rHasChain v a as es = .ok r → ∃ b, r = .prim (.bool b) := by + induction as generalizing v a with + | nil => + intro r h + simp [Cst.rHasChain] at h + exact hasAttr_isBool h + | cons b bs ih => + intro r h + simp [Cst.rHasChain, bind, Except.bind] at h + split at h + · simp at h + · rename_i hv + obtain ⟨b'', hb''⟩ := hasAttr_isBool hv + rw [hb''] at h + split at h + · simp at h; rw [← h]; exact ⟨false, rfl⟩ + · split at h + · simp at h + · exact ih _ _ _ h + +/-- The AST expression `extendedHasAttr target (a :: as)` evaluates the same as + the evaluator's `rHasChain v a as`, when `target` evaluates to value `v`. -/ +theorem extendedHasAttr_evaluate_agrees + (target : Expr) (a : Attr) (as : List Attr) (req : Request) (es : Entities) (v : Value) : + evaluate target req es = .ok v → + evaluate (Cst.extendedHasAttr target (a :: as)) req es = Cst.rHasChain v a as es := by + intro htarget + induction as generalizing target a v with + | nil => + simp [Cst.extendedHasAttr, evaluate, htarget, bind, Except.bind, Cst.rHasChain] + | cons b bs ih => + cases hh : hasAttr v a es with + | error err => + simp [Cst.extendedHasAttr, evaluate, htarget, bind, Except.bind, hh, + Result.as, Cst.rHasChain] + | ok hv => + obtain ⟨b', hb'⟩ := hasAttr_isBool hh + subst hb' + cases b' with + | false => + simp [Cst.extendedHasAttr, evaluate, htarget, bind, Except.bind, hh, + Result.as, Coe.coe, Value.asBool, Cst.rHasChain] + | true => + cases hga : getAttr v a es with + | error err => + have hgetAttr : evaluate (.getAttr target a) req es = .error err := by + simp [evaluate, htarget, bind, Except.bind, hga] + cases bs with + | nil => + simp [Cst.extendedHasAttr, evaluate, htarget, hgetAttr, bind, Except.bind, + hh, hga, Result.as, Coe.coe, Value.asBool, Cst.rHasChain] + | cons c cs => + simp [Cst.extendedHasAttr, evaluate, htarget, hgetAttr, bind, Except.bind, + hh, hga, Result.as, Coe.coe, Value.asBool, Cst.rHasChain] + | ok v' => + have hgetAttr : evaluate (.getAttr target a) req es = .ok v' := by + simp [evaluate, htarget, bind, Except.bind, hga] + have ih' := ih (target := .getAttr target a) (a := b) (v := v') hgetAttr + simp [Cst.extendedHasAttr, evaluate, htarget, bind, Except.bind, hh, hga, + Result.as, Coe.coe, Value.asBool, Cst.rHasChain] + rw [ih'] + cases hrhc : Cst.rHasChain v' b bs es with + | error err => simp + | ok rv => + obtain ⟨b'', hb''⟩ := rHasChain_isBool v' b bs es rv hrhc + subst hb'' + rfl + +/-- Reduction: with no accessors, `memberAux` returns the head unchanged. -/ +theorem memberAux_nil (ieos : Cst.ExprOrSpecial) : + Cst.memberAux ieos [] = some ieos := rfl + +/-- Reduction: feeding an `.expr e` head through `memberAux` is the same as + running `memberAuxB` on `e` and wrapping the result back up as an `.expr`. -/ +private theorem memberAux_expr_eq (e : Expr) (accs : List Cst.AstAccessor) : + Cst.memberAux (.expr e) accs = (Cst.memberAuxB e accs).bind (fun r => some (.expr r)) := by + cases accs with + | nil => rfl + | cons acc rest => rfl + +/-- On a non-empty accessor list, `memberAuxA` never returns `.inl` — the + `.inl` (pass-through) result only arises for the empty accessor list. -/ +private theorem memberAuxA_cons_ne_inl + (ieos : Cst.ExprOrSpecial) (acc : Cst.AstAccessor) (rest : List Cst.AstAccessor) (eos : Cst.ExprOrSpecial) : + Cst.memberAuxA ieos (acc :: rest) ≠ some (.inl eos) := by + intro h + cases ieos <;> cases acc <;> + (try (cases rest <;> (try (rename_i a2 _; cases a2)))) <;> + simp_all [Cst.memberAuxA, Cst.ExprOrSpecial.toExpr?, Option.bind_eq_some_iff] + +/-- If `memberAux` succeeds, either there were no accessors (and the result is + the unchanged head) or the result is an `.expr`. -/ +theorem memberAux_some_cases {ieos r : Cst.ExprOrSpecial} {accs : List Cst.AstAccessor} : + Cst.memberAux ieos accs = some r → + (accs = [] ∧ r = ieos) ∨ (∃ e, r = .expr e) := by + cases accs with + | nil => + intro h + rw [memberAux_nil] at h + exact Or.inl ⟨rfl, (Option.some.inj h).symm⟩ + | cons acc rest => + intro h + refine Or.inr ?_ + cases hA : Cst.memberAuxA ieos (acc :: rest) with + | none => simp [Cst.memberAux, hA] at h + | some reta => + cases reta with + | inl eos => exact absurd hA (memberAuxA_cons_ne_inl ieos acc rest eos) + | inr p => + obtain ⟨e, rest'⟩ := p + simp [Cst.memberAux, hA, Option.bind_eq_some_iff] at h + obtain ⟨ret, _, hr⟩ := h + subst hr + exact ⟨ret, rfl⟩ + +/-- Helper: `memberAux ieos accs = some (.strLit lit)` requires `accs = []` + and `ieos = .strLit lit`. -/ +private theorem memberAux_eq_strLit + {ieos : Cst.ExprOrSpecial} {accs : List Cst.AstAccessor} {lit : String} : + Cst.memberAux ieos accs = some (.strLit lit) → + accs = [] ∧ ieos = .strLit lit := by + intro h + rcases memberAux_some_cases h with ⟨haccs, hr⟩ | ⟨_, hr⟩ + · exact ⟨haccs, hr.symm⟩ + · exact absurd hr (by simp) + +/-- Helper: `Cst.Primary.toExprOrSpecial? p = some (.strLit lit)` iff + `p = .literal (.liStr lit)`. -/ +private theorem primary_toExprOrSpecial_strLit + {p : Cst.Primary} {lit : String} : + p.toExprOrSpecial? = some (.strLit lit) → + p = .literal (.liStr lit) := by + intro h + cases p with + | literal lit' => + cases lit' with + | liStr s => + simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?] at h + rw [h] + | liTrue | liFalse => + simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?] at h + | liNum _ => + simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?, + Option.bind_eq_some_iff] at h + | name _ => + simp [Cst.Primary.toExprOrSpecial?] at h + split at h + · simp at h + · simp [Option.bind_eq_some_iff] at h + | ref r => + cases r with + | uid _ eid => + cases eid with + | string _ => + simp [Cst.Primary.toExprOrSpecial?, Cst.Ref.toExprOrSpecial?, + Option.bind_eq_some_iff] at h + | ref _ _ => + simp [Cst.Primary.toExprOrSpecial?, Cst.Ref.toExprOrSpecial?] at h + | expr _ => + simp [Cst.Primary.toExprOrSpecial?, Option.bind_eq_some_iff] at h + | eList _ => + simp [Cst.Primary.toExprOrSpecial?, Option.bind_eq_some_iff] at h + | rInits _ => + simp [Cst.Primary.toExprOrSpecial?, Option.bind_eq_some_iff] at h + | slot _ => + simp [Cst.Primary.toExprOrSpecial?] at h +/-- Helper: `Cst.Member.toExprOrSpecial? m = some (.strLit lit)` iff + `m.access = []` and `m.item = .literal (.liStr lit)`. -/ +private theorem member_toExprOrSpecial_strLit + {m : Cst.Member} {lit : String} : + m.toExprOrSpecial? = some (.strLit lit) → + m.access = [] ∧ m.item = .literal (.liStr lit) := by + intro h + simp [Cst.Member.toExprOrSpecial?, Option.bind_eq_some_iff] at h + obtain ⟨ieos, hieos, accs, haccs, hmaux⟩ := h + obtain ⟨hAccs, hIeos⟩ := memberAux_eq_strLit hmaux + subst hAccs + refine ⟨?_, primary_toExprOrSpecial_strLit (hIeos ▸ hieos)⟩ + cases hAcc : m.access with + | nil => rfl + | cons _ _ => + rw [hAcc] at haccs + simp [List.mapM_cons, Option.bind_eq_some_iff] at haccs + +/-- For the `rLike` case: if the translator's `toPattern?` succeeds with `p`, + then the evaluator's `toPatternString?` succeeds with some `s` such that + `Cst.toPattern? s = some p`. + + Both functions enforce the same shape (extended/op/access empty, item is + a `liStr`) and call `Cst.toPattern?` on the same raw string. -/ +theorem addExpr_toPattern_toPatternString_agrees + {e : Cst.AddExpr} {p : Pattern} : + Cst.AddExpr.toPattern? e = some p → + ∃ s, Cst.AddExpr.toPatternString? e = some s ∧ + Cst.toPattern? s = some p := by + intro h + simp [Cst.AddExpr.toPattern?, Option.bind_eq_some_iff] at h + obtain ⟨eos, heos, hmatch⟩ := h + -- For the inner match to succeed, eos must be .strLit lit. + cases eos with + | expr _ | var _ | name _ | boolLit _ => simp at hmatch + | strLit lit => + simp at hmatch + refine ⟨lit, ?_, hmatch⟩ + -- Trace `e.toExprOrSpecial? = some (.strLit lit)` through the chain. + -- The chain delegates to the underlying member only when extended/mext + -- are empty AND op is `none` or `.nDash 0`. + obtain ⟨⟨⟨op, member⟩, mext⟩, ext⟩ := e + simp [Cst.AddExpr.toExprOrSpecial?, Cst.MultExpr.toExprOrSpecial?, + Cst.Unary.toExprOrSpecial?] at heos + -- ext = [] required; otherwise produces .expr. + cases ext with + | cons _ _ => + simp [Option.bind_eq_some_iff] at heos + | nil => + simp at heos + cases mext with + | cons _ _ => + simp [Option.bind_eq_some_iff] at heos + | nil => + simp at heos + -- Now the unary's match on `op` runs. Show op ∈ {none, .nDash 0}. + cases op with + | none => + obtain ⟨hAccNil, hItem⟩ := member_toExprOrSpecial_strLit heos + simp [Cst.AddExpr.toPatternString?, hAccNil, hItem] + | some op' => + cases op' with + | nDash n => + by_cases hn : n = 0 + · subst hn + obtain ⟨hAccNil, hItem⟩ := member_toExprOrSpecial_strLit heos + simp [Cst.AddExpr.toPatternString?, hAccNil, hItem] + · simp at heos + -- For non-zero n, falls into the toLit?/eos chain producing .expr/none. + split at heos + · split at heos + · simp at heos + · split at heos + · simp at heos + · simp at heos + · simp at heos + · simp [Option.bind_eq_some_iff] at heos + | nBang _ => + simp [Option.bind_eq_some_iff] at heos + +/-- Converse direction (eval ⟹ translate) for `rLike`: if the evaluator's + `toPatternString?` succeeds with `s`, then the AddExpr translates to the + string-literal special form `.strLit s`. Both functions accept exactly the + bare string-literal shape (extended/op/access empty, item a `liStr`). -/ +theorem addExpr_toPatternString_toExprOrSpecial {e : Cst.AddExpr} {s : String} : + Cst.AddExpr.toPatternString? e = some s → + e.toExprOrSpecial? = some (.strLit s) := by + intro h + obtain ⟨⟨⟨op, ⟨prim, access⟩⟩, mext⟩, ext⟩ := e + simp only [Cst.AddExpr.toPatternString?] at h + cases ext with + | cons _ _ => simp at h + | nil => + cases mext with + | cons _ _ => simp at h + | nil => + cases op with + | none => + cases access with + | cons _ _ => simp at h + | nil => + cases prim with + | literal lit => + cases lit with + | liStr str => + simp at h; subst h + simp [Cst.AddExpr.toExprOrSpecial?, Cst.MultExpr.toExprOrSpecial?, + Cst.Unary.toExprOrSpecial?, Cst.Member.toExprOrSpecial?, + Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?, + Cst.memberAux, Cst.memberAuxA, List.mapM_nil] + | liTrue | liFalse | liNum _ => simp at h + | ref _ | name _ | expr _ | slot _ | eList _ | rInits _ => simp at h + | some o => + cases o with + | nDash n => + by_cases hn : n = 0 + · subst hn + cases access with + | cons _ _ => simp at h + | nil => + cases prim with + | literal lit => + cases lit with + | liStr str => + simp at h; subst h + simp [Cst.AddExpr.toExprOrSpecial?, Cst.MultExpr.toExprOrSpecial?, + Cst.Unary.toExprOrSpecial?, Cst.Member.toExprOrSpecial?, + Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?, + Cst.memberAux, Cst.memberAuxA, List.mapM_nil] + | liTrue | liFalse | liNum _ => simp at h + | ref _ | name _ | expr _ | slot _ | eList _ | rInits _ => simp at h + · simp [hn] at h + | nBang _ => simp at h + +/-- Helper: `memberAux ieos accs = some (.name an)` requires `accs = []` + and `ieos = .name an`. -/ +private theorem memberAux_eq_name + {ieos : Cst.ExprOrSpecial} {accs : List Cst.AstAccessor} {an : Spec.Name} : + Cst.memberAux ieos accs = some (.name an) → + accs = [] ∧ ieos = .name an := by + intro h + rcases memberAux_some_cases h with ⟨haccs, hr⟩ | ⟨_, hr⟩ + · exact ⟨haccs, hr.symm⟩ + · exact absurd hr (by simp) + +/-- Helper: `Cst.Primary.toExprOrSpecial? p = some (.name an)` requires `p` to + be a `.name n` with `n.toAName? = some an`. -/ +private theorem primary_toExprOrSpecial_name + {p : Cst.Primary} {an : Spec.Name} : + p.toExprOrSpecial? = some (.name an) → + ∃ n, p = .name n ∧ n.toAName? = some an := by + intro h + cases p with + | literal lit' => + cases lit' with + | liStr s => + simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?] at h + | liTrue | liFalse => + simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?] at h + | liNum _ => + simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?, + Option.bind_eq_some_iff] at h + | name n => + have hdef : Cst.Primary.toExprOrSpecial? (.name n) = + (match n.toVar? with + | some v => some (Cst.ExprOrSpecial.var v) + | none => n.toAName?.map Cst.ExprOrSpecial.name) := by + simp [Cst.Primary.toExprOrSpecial?] + cases n.toVar? with + | some v => rfl + | none => + simp [Option.bind, Option.map] + cases n.toAName? with + | none => rfl + | some a => rfl + rw [hdef] at h + cases hv : n.toVar? with + | some v => simp [hv] at h + | none => + simp [hv, Option.map] at h + cases hname : n.toAName? with + | none => simp [hname] at h + | some a => simp [hname] at h; exact ⟨n, rfl, h ▸ hname⟩ + | ref r => + cases r with + | uid _ eid => + cases eid with + | string _ => + simp [Cst.Primary.toExprOrSpecial?, Cst.Ref.toExprOrSpecial?, + Option.bind_eq_some_iff] at h + | ref _ _ => + simp [Cst.Primary.toExprOrSpecial?, Cst.Ref.toExprOrSpecial?] at h + | expr _ => + simp [Cst.Primary.toExprOrSpecial?, Option.bind_eq_some_iff] at h + | eList _ => + simp [Cst.Primary.toExprOrSpecial?, Option.bind_eq_some_iff] at h + | rInits _ => + simp [Cst.Primary.toExprOrSpecial?, Option.bind_eq_some_iff] at h + | slot _ => + simp [Cst.Primary.toExprOrSpecial?] at h +/-- Helper: `Cst.Member.toExprOrSpecial? m = some (.name an)` requires + `m.access = []` and `m.item = .name n` with `n.toAName? = some an`. -/ +private theorem member_toExprOrSpecial_name + {m : Cst.Member} {an : Spec.Name} : + m.toExprOrSpecial? = some (.name an) → + m.access = [] ∧ ∃ n, m.item = .name n ∧ n.toAName? = some an := by + intro h + simp [Cst.Member.toExprOrSpecial?, Option.bind_eq_some_iff] at h + obtain ⟨ieos, hieos, accs, haccs, hmaux⟩ := h + obtain ⟨hAccs, hIeos⟩ := memberAux_eq_name hmaux + subst hAccs + obtain ⟨n, hItem, hAName⟩ := primary_toExprOrSpecial_name (hIeos ▸ hieos) + refine ⟨?_, n, hItem, hAName⟩ + cases hAcc : m.access with + | nil => rfl + | cons _ _ => + rw [hAcc] at haccs + simp [List.mapM_cons, Option.bind_eq_some_iff] at haccs + +/-- Helper: `memberAux ieos accs = some (.var v)` requires `accs = []`. -/ +private theorem memberAux_eq_var + {ieos : Cst.ExprOrSpecial} {accs : List Cst.AstAccessor} {v : Var} : + Cst.memberAux ieos accs = some (.var v) → accs = [] := by + intro h + rcases memberAux_some_cases h with ⟨haccs, _⟩ | ⟨_, hr⟩ + · exact haccs + · exact absurd hr (by simp) + +/-- A member with non-empty access never yields a valid record-key attribute. -/ +private theorem member_nonempty_validAttr {m : Cst.Member} (h : m.access ≠ []) : + m.toExprOrSpecial?.bind Cst.ExprOrSpecial.toValidAttr? = none := by + cases heos : m.toExprOrSpecial? with + | none => rfl + | some eos => + cases eos with + | expr e => rfl + | boolLit b => rfl + | strLit lit => exact absurd (member_toExprOrSpecial_strLit heos).1 h + | name an => exact absurd (member_toExprOrSpecial_name heos).1 h + | var v => + exfalso + simp [Cst.Member.toExprOrSpecial?, Option.bind_eq_some_iff] at heos + obtain ⟨ieos, hieos, accs, haccs, hmaux⟩ := heos + have haccsNil := memberAux_eq_var hmaux + subst haccsNil + cases hAcc : m.access with + | nil => exact h hAcc + | cons _ _ => rw [hAcc] at haccs; simp [List.mapM_cons, Option.bind_eq_some_iff] at haccs + +/-- Definitional reductions for `memberAuxB` (sidestep overlapping-pattern simp). -/ +private theorem memberAuxB_index (he : Expr) (id : String) (rest : List Cst.AstAccessor) : + Cst.memberAuxB he (.index id :: rest) = Cst.memberAuxB (.getAttr he id) rest := rfl +private theorem memberAuxB_field_call (he : Expr) (id : Cst.Ident) (args : List Expr) (rest : List Cst.AstAccessor) : + Cst.memberAuxB he (.field id :: .call args :: rest) + = (id.toMeth? he args).bind (fun h' => Cst.memberAuxB h' rest) := rfl +private theorem memberAuxB_field_nil (he : Expr) (id : Cst.Ident) : + Cst.memberAuxB he [.field id] = some (.getAttr he (Cst.Ident.toString id)) := rfl +private theorem memberAuxB_field_field (he : Expr) (id id2 : Cst.Ident) (rest2 : List Cst.AstAccessor) : + Cst.memberAuxB he (.field id :: .field id2 :: rest2) + = Cst.memberAuxB (.getAttr he (Cst.Ident.toString id)) (.field id2 :: rest2) := rfl +private theorem memberAuxB_field_index (he : Expr) (id : Cst.Ident) (id2 : String) (rest2 : List Cst.AstAccessor) : + Cst.memberAuxB he (.field id :: .index id2 :: rest2) + = Cst.memberAuxB (.getAttr he (Cst.Ident.toString id)) (.index id2 :: rest2) := rfl + +/-- Bridge: collapsing `memberAux` of a (non-name) head through `toExpr?` equals + running `memberAuxB` on the collapsed head expression. -/ +theorem memberAux_toExpr_eq + {peos : Cst.ExprOrSpecial} {headExpr : Expr} (accs : List Cst.AstAccessor) + (hpe : peos.toExpr? = some headExpr) : + (Cst.memberAux peos accs).bind Cst.ExprOrSpecial.toExpr? = Cst.memberAuxB headExpr accs := by + cases peos with + | name n => simp [Cst.ExprOrSpecial.toExpr?] at hpe + | expr e => + simp only [Cst.ExprOrSpecial.toExpr?, Option.some.injEq] at hpe; subst hpe + rw [memberAux_expr_eq]; cases Cst.memberAuxB e accs <;> rfl + | boolLit b => + simp only [Cst.ExprOrSpecial.toExpr?, Option.some.injEq] at hpe; subst hpe + cases accs with + | nil => rfl + | cons acc rest => + simp [Cst.memberAux, Cst.memberAuxA, Cst.ExprOrSpecial.toExpr?] + cases Cst.memberAuxB (Expr.lit (.bool b)) (acc :: rest) <;> rfl + | strLit s => + cases hus : Cst.unescape? s with + | none => simp [Cst.ExprOrSpecial.toExpr?, hus] at hpe + | some us => + simp [Cst.ExprOrSpecial.toExpr?, hus] at hpe + subst hpe + cases accs with + | nil => simp [memberAux_nil, Cst.ExprOrSpecial.toExpr?, hus]; rfl + | cons acc rest => + simp [Cst.memberAux, Cst.memberAuxA, Cst.ExprOrSpecial.toExpr?, hus] + cases Cst.memberAuxB (Expr.lit (.string us)) (acc :: rest) <;> rfl + | var v => + simp only [Cst.ExprOrSpecial.toExpr?, Option.some.injEq] at hpe; subst hpe + cases accs with + | nil => rfl + | cons acc rest => + cases acc with + | call args => rfl + | index id => + simp [Cst.memberAux, Cst.memberAuxA, memberAuxB_index] + cases Cst.memberAuxB (Expr.getAttr (.var v) id) rest <;> rfl + | field id => + cases rest with + | nil => rfl + | cons acc2 rest2 => + cases acc2 with + | call args => + rw [memberAuxB_field_call] + cases hm : Cst.Ident.toMeth? id (.var v) args with + | none => simp [Cst.memberAux, Cst.memberAuxA, Cst.ExprOrSpecial.toExpr?, hm] + | some e => + simp [Cst.memberAux, Cst.memberAuxA, Cst.ExprOrSpecial.toExpr?, hm] + cases Cst.memberAuxB e rest2 <;> rfl + | field id2 => + simp [Cst.memberAux, Cst.memberAuxA, memberAuxB_field_field] + cases Cst.memberAuxB (Expr.getAttr (.var v) (Cst.Ident.toString id)) (.field id2 :: rest2) <;> rfl + | index id2 => + simp [Cst.memberAux, Cst.memberAuxA, memberAuxB_field_index] + cases Cst.memberAuxB (Expr.getAttr (.var v) (Cst.Ident.toString id)) (.index id2 :: rest2) <;> rfl + +/-- When a method-call translation's receiver errors, the method application + propagates the head error *unchanged*. -/ +private theorem toMeth?_eval_error_eq + {req : Request} {es : Entities} {id : Cst.Ident} {he head' : Expr} + {args : List Expr} {err : Error} + (hm : Cst.Ident.toMeth? id he args = some head') + (herr : evaluate he req es = .error err) : + evaluate head' req es = .error err := by + cases id with + | idIdent s hs_kw => + cases hop : Cst.String.toMethodOp? s with + | none => simp [Cst.Ident.toMeth?, hop] at hm + | some op => + cases op with + | inl bop => + cases args with + | nil => simp [Cst.Ident.toMeth?, hop, Cst.oneArg?] at hm + | cons a as => + cases as with + | cons _ _ => simp [Cst.Ident.toMeth?, hop, Cst.oneArg?] at hm + | nil => + simp [Cst.Ident.toMeth?, hop, Cst.oneArg?] at hm + subst hm + simp [evaluate, herr, bind, Except.bind] + | inr uop => + cases hargs : args.isEmpty with + | false => simp [Cst.Ident.toMeth?, hop, hargs] at hm + | true => + simp [Cst.Ident.toMeth?, hop, hargs] at hm + subst hm + simp [evaluate, herr, bind, Except.bind] + | _ => simp [Cst.Ident.toMeth?] at hm + +/-- When the head errors, the whole `memberAuxB`-built expression errors with + the *same* error. -/ +theorem memberAuxB_eval_error_eq + {req : Request} {es : Entities} : + (accs : List Cst.AstAccessor) → (he bexp : Expr) → (err : Error) → + Cst.memberAuxB he accs = some bexp → evaluate he req es = .error err → + evaluate bexp req es = .error err + | [], _, bexp, err, hb, herr => by + simp only [Cst.memberAuxB, Option.some.injEq] at hb; subst hb; exact herr + | .call args :: rest, _, bexp, _, hb, _ => by + simp [Cst.memberAuxB] at hb + | .index id :: rest, he, bexp, err, hb, herr => by + rw [memberAuxB_index] at hb + exact memberAuxB_eval_error_eq rest _ bexp err hb (by simp [evaluate, herr, bind, Except.bind]) + | .field id :: [], he, bexp, err, hb, herr => by + rw [memberAuxB_field_nil] at hb; simp only [Option.some.injEq] at hb; subst hb + simp [evaluate, herr, bind, Except.bind] + | .field id :: .call args :: rest2, he, bexp, err, hb, herr => by + rw [memberAuxB_field_call, Option.bind_eq_some_iff] at hb + obtain ⟨head', hmeth, hrec⟩ := hb + exact memberAuxB_eval_error_eq rest2 head' bexp err hrec (toMeth?_eval_error_eq hmeth herr) + | .field id :: .field id2 :: rest2, he, bexp, err, hb, herr => by + rw [memberAuxB_field_field] at hb + exact memberAuxB_eval_error_eq (.field id2 :: rest2) _ bexp err hb + (by simp [evaluate, herr, bind, Except.bind]) + | .field id :: .index id2 :: rest2, he, bexp, err, hb, herr => by + rw [memberAuxB_field_index] at hb + exact memberAuxB_eval_error_eq (.index id2 :: rest2) _ bexp err hb + (by simp [evaluate, herr, bind, Except.bind]) +termination_by accs => accs.length +decreasing_by all_goals (simp_wf <;> omega) + +/-- One step of the member-access agreement, as an evaluation equality. -/ +theorem evalAccessors_step_eq + {req : Request} {es : Entities} {he' bexp : Expr} {cstStep : Result Value} + {rest_cst : List Cst.MemAccess} {rest_ast : List Cst.AstAccessor} + (hstep : evaluate he' req es = cstStep) + (hbrec : Cst.memberAuxB he' rest_ast = some bexp) + (htail : ∀ hv', evaluate he' req es = .ok hv' → + evaluate bexp req es = Cst.Member.evalAccessors hv' rest_cst req es) : + evaluate bexp req es = + (do let hv ← cstStep; Cst.Member.evalAccessors hv rest_cst req es) := by + cases hcs : cstStep with + | error e => + have hge : evaluate he' req es = .error e := by rw [hstep, hcs] + rw [memberAuxB_eval_error_eq rest_ast he' bexp e hbrec hge] + simp [bind, Except.bind] + | ok hv' => + have hge : evaluate he' req es = .ok hv' := by rw [hstep, hcs] + rw [htail hv' hge] + simp [bind, Except.bind] + +/-- A `.field`-headed CST accessor list translates to a `.field`-headed AST list. -/ +private theorem mapM_toAst_field_head {i2 : Cst.Ident} {rest2 : List Cst.MemAccess} + {tl_ast : List Cst.AstAccessor} : + (Cst.MemAccess.field i2 :: rest2).mapM Cst.MemAccess.toAstAccessor? = some tl_ast → + ∃ id r, tl_ast = .field id :: r := by + intro h + simp only [List.mapM_cons, Option.pure_def, Option.bind_eq_bind, Option.bind_eq_some_iff, + Option.some.injEq] at h + obtain ⟨a2, ha2, r2, _, rfl⟩ := h + cases i2 with + | idIdent s2 hs2 => + simp only [Cst.MemAccess.toAstAccessor?, Option.bind_eq_bind, Option.bind_eq_some_iff, + Option.some.injEq] at ha2 + obtain ⟨s2, _, rfl⟩ := ha2 + exact ⟨_, _, rfl⟩ + | _ => simp [Cst.MemAccess.toAstAccessor?] at ha2 + +/-- An `.index`-headed CST accessor list translates to an `.index`-headed AST list. -/ +private theorem mapM_toAst_index_head {ex2 : Cst.Expr} {rest2 : List Cst.MemAccess} + {tl_ast : List Cst.AstAccessor} : + (Cst.MemAccess.index ex2 :: rest2).mapM Cst.MemAccess.toAstAccessor? = some tl_ast → + ∃ id r, tl_ast = .index id :: r := by + intro h + simp only [List.mapM_cons, Option.pure_def, Option.bind_eq_bind, Option.bind_eq_some_iff, + Option.some.injEq] at h + obtain ⟨a2, ha2, r2, _, rfl⟩ := h + simp only [Cst.MemAccess.toAstAccessor?, Option.bind_eq_bind, Option.bind_eq_some_iff, + Option.some.injEq] at ha2 + obtain ⟨s2, _, rfl⟩ := ha2 + exact ⟨_, _, rfl⟩ + +/-- Core member-access agreement (evaluation equality): the AST built by + `memberAuxB` over a head evaluates as the CST member-access spine does. -/ +theorem evalAccessors_eq + {req : Request} {es : Entities} : + (accs_cst : List Cst.MemAccess) → (accs_ast : List Cst.AstAccessor) → + (headExpr bexp : Expr) → (head : Value) → + accs_cst.mapM Cst.MemAccess.toAstAccessor? = some accs_ast → + Cst.memberAuxB headExpr accs_ast = some bexp → + evaluate headExpr req es = .ok head → + (∀ ce : Cst.Expr, sizeOf ce < sizeOf accs_cst → ∀ ax, ce.toAExpr? = some ax → + evaluate ax req es = ce.evaluate req es) → + evaluate bexp req es = Cst.Member.evalAccessors head accs_cst req es + | [], accs_ast, headExpr, bexp, head, htrans, hb, hhead, _ => by + simp at htrans; subst htrans + simp only [Cst.memberAuxB, Option.some.injEq] at hb; subst hb + rw [hhead]; simp [Cst.Member.evalAccessors] + | .call args :: rest, accs_ast, headExpr, bexp, head, htrans, hb, hhead, _ => by + rw [List.mapM_cons] at htrans + simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at htrans + obtain ⟨a_ast, ha_ast, rest_ast, _, rfl⟩ := htrans + simp only [Cst.MemAccess.toAstAccessor?, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at ha_ast + obtain ⟨xs, _, rfl⟩ := ha_ast + simp [Cst.memberAuxB] at hb + | .index ex :: rest, accs_ast, headExpr, bexp, head, htrans, hb, hhead, harg => by + rw [List.mapM_cons] at htrans + simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at htrans + obtain ⟨a_ast, ha_ast, rest_ast, hrest, rfl⟩ := htrans + simp only [Cst.MemAccess.toAstAccessor?, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at ha_ast + obtain ⟨s, hs, rfl⟩ := ha_ast + rw [memberAuxB_index] at hb + have hev : Cst.Member.evalAccessors head (.index ex :: rest) req es + = (do let hv ← getAttr head s es; Cst.Member.evalAccessors hv rest req es) := by + simp [Cst.Member.evalAccessors, hs] + rw [hev] + exact evalAccessors_step_eq (he' := .getAttr headExpr s) (cstStep := getAttr head s es) + (by simp [evaluate, hhead, bind, Except.bind]) hb + (fun hv' hge => evalAccessors_eq rest rest_ast (.getAttr headExpr s) bexp hv' + hrest hb hge (fun ce hsz => harg ce (Nat.lt_trans hsz (by simp only [List.cons.sizeOf_spec]; omega)))) + | .field i :: [], accs_ast, headExpr, bexp, head, htrans, hb, hhead, harg => by + simp only [List.mapM_cons, List.mapM_nil, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.pure_def, + Option.some.injEq] at htrans + obtain ⟨a_ast, ha_ast, rest_ast, hrest, rfl⟩ := htrans + cases i with + | idIdent s0 hs0 => + simp only [Cst.MemAccess.toAstAccessor?, Cst.Ident.toUnreservedString?, Cst.Unreserved?, + Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at ha_ast + obtain ⟨s, hs, rfl⟩ := ha_ast + subst hrest + have hs_eq : s = s0 := by simp at hs; exact hs.2.symm + rw [memberAuxB_field_nil] at hb + have hev : Cst.Member.evalAccessors head [.field (.idIdent s0 hs0)] req es + = (do let hv ← Spec.getAttr head s0 es; Cst.Member.evalAccessors hv [] req es) := by + simp [Cst.Member.evalAccessors] + have hstep : evaluate (Expr.getAttr headExpr s0) req es + = Spec.getAttr head s0 es := by + simp [evaluate, hhead, bind, Except.bind] + have hbrec : Cst.memberAuxB (Expr.getAttr headExpr s0) [] = some bexp := hb + rw [hev] + exact evalAccessors_step_eq hstep hbrec + (fun hv' hge => evalAccessors_eq [] [] _ bexp hv' (by simp) hbrec hge + (fun ce hsz => harg ce (Nat.lt_trans hsz (by simp only [List.cons.sizeOf_spec]; omega)))) + | _ => simp [Cst.MemAccess.toAstAccessor?] at ha_ast + | .field i :: .call args :: rest2, accs_ast, headExpr, bexp, head, htrans, hb, hhead, harg => by + rw [List.mapM_cons] at htrans + simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at htrans + obtain ⟨a_ast, ha_ast, tl_ast, htl, rfl⟩ := htrans + cases i with + | idIdent s0 hs0 => + simp only [Cst.MemAccess.toAstAccessor?, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at ha_ast + obtain ⟨s, hs, rfl⟩ := ha_ast + have hs_eq : s = s0 := by simp at hs; exact hs.symm + subst hs_eq + rw [List.mapM_cons] at htl + simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at htl + obtain ⟨a2_ast, ha2_ast, rest2_ast, hrest2, rfl⟩ := htl + simp only [Cst.MemAccess.toAstAccessor?, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at ha2_ast + obtain ⟨xs, hxs, rfl⟩ := ha2_ast + rw [memberAuxB_field_call] at hb + cases hop : Cst.String.toMethodOp? s with + | none => simp [Cst.Ident.toMeth?, hop] at hb + | some op => + cases op with + | inl bop => + cases args with + | nil => simp [Cst.Expr.toAExprs?] at hxs; subst hxs; simp [Cst.Ident.toMeth?, hop, Cst.oneArg?] at hb + | cons arg rest_args => + cases rest_args with + | cons a2 r2 => + simp only [Cst.Expr.toAExprs?, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at hxs + obtain ⟨ax, hax, xs2, hxs2, rfl⟩ := hxs + obtain ⟨bx, hbx, xs3, hxs3, rfl⟩ := hxs2 + simp [Cst.Ident.toMeth?, hop, Cst.oneArg?] at hb + | nil => + simp only [Cst.Expr.toAExprs?, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at hxs + obtain ⟨ax, hax, a, rfl, rfl⟩ := hxs + simp only [Cst.Ident.toMeth?, hop, Cst.oneArg?, Option.bind_eq_bind, Option.bind_some] at hb + have hagr := harg arg (by simp only [List.cons.sizeOf_spec, Cst.MemAccess.call.sizeOf_spec]; omega) ax hax + have hstep : evaluate (Expr.binaryApp bop headExpr ax) req es + = (do let argVal ← arg.evaluate req es; apply₂ bop head argVal es) := by + simp [evaluate, hhead, hagr, bind, Except.bind] + have hev : Cst.Member.evalAccessors head (.field (.idIdent s hs0) :: .call [arg] :: rest2) req es + = (do let hv ← (do let argVal ← arg.evaluate req es; apply₂ bop head argVal es); + Cst.Member.evalAccessors hv rest2 req es) := by + simp [Cst.Member.evalAccessors, hs, hop, bind_assoc] + rw [hev] + exact evalAccessors_step_eq hstep hb + (fun hv' hge => evalAccessors_eq rest2 rest2_ast (.binaryApp bop headExpr ax) bexp hv' + hrest2 hb hge (fun ce hsz => harg ce (Nat.lt_trans hsz + (by simp only [List.cons.sizeOf_spec, Cst.MemAccess.call.sizeOf_spec]; omega)))) + | inr uop => + cases args with + | cons arg rest_args => + simp only [Cst.Expr.toAExprs?, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at hxs + obtain ⟨ax, hax, xs2, hxs2, rfl⟩ := hxs + simp [Cst.Ident.toMeth?, hop] at hb + | nil => + simp only [Cst.Expr.toAExprs?, Option.some.injEq] at hxs; subst hxs + simp only [Cst.Ident.toMeth?, hop, List.isEmpty_nil, if_true] at hb + have hstep : evaluate (Expr.unaryApp uop headExpr) req es = apply₁ uop head := by + simp [evaluate, hhead, bind, Except.bind] + have hev : Cst.Member.evalAccessors head (.field (.idIdent s hs0) :: .call [] :: rest2) req es + = (do let hv ← apply₁ uop head; Cst.Member.evalAccessors hv rest2 req es) := by + simp [Cst.Member.evalAccessors, hs, hop, bind, Except.bind] + rw [hev] + exact evalAccessors_step_eq hstep hb + (fun hv' hge => evalAccessors_eq rest2 rest2_ast (.unaryApp uop headExpr) bexp hv' + hrest2 hb hge (fun ce hsz => harg ce (Nat.lt_trans hsz + (by simp only [List.cons.sizeOf_spec, Cst.MemAccess.call.sizeOf_spec]; omega)))) + | _ => simp [Cst.MemAccess.toAstAccessor?] at ha_ast + | .field i :: .field i2 :: rest2, accs_ast, headExpr, bexp, head, htrans, hb, hhead, harg => by + rw [List.mapM_cons] at htrans + simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at htrans + obtain ⟨a_ast, ha_ast, tl_ast, htl, rfl⟩ := htrans + cases i with + | idIdent s0 hs0 => + simp only [Cst.MemAccess.toAstAccessor?, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at ha_ast + obtain ⟨s, hs, rfl⟩ := ha_ast + obtain ⟨id2, r2, htl_shape⟩ := mapM_toAst_field_head htl + rw [htl_shape, memberAuxB_field_field, ← htl_shape] at hb + have hev : Cst.Member.evalAccessors head (.field (.idIdent s0 hs0) :: .field i2 :: rest2) req es + = (do let hv ← getAttr head s0 es; Cst.Member.evalAccessors hv (.field i2 :: rest2) req es) := by + simp [Cst.Member.evalAccessors] + have hstep : evaluate (Expr.getAttr headExpr (s0)) req es + = getAttr head s0 es := by + simp [evaluate, hhead, bind, Except.bind] + rw [hev] + exact evalAccessors_step_eq hstep hb + (fun hv' hge => evalAccessors_eq (.field i2 :: rest2) tl_ast _ bexp hv' + htl hb hge (fun ce hsz => harg ce (Nat.lt_trans hsz (by simp only [List.cons.sizeOf_spec]; omega)))) + | _ => simp [Cst.MemAccess.toAstAccessor?] at ha_ast + | .field i :: .index ex2 :: rest2, accs_ast, headExpr, bexp, head, htrans, hb, hhead, harg => by + rw [List.mapM_cons] at htrans + simp only [Option.pure_def, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at htrans + obtain ⟨a_ast, ha_ast, tl_ast, htl, rfl⟩ := htrans + cases i with + | idIdent s0 hs0 => + simp only [Cst.MemAccess.toAstAccessor?, Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq] at ha_ast + obtain ⟨s, hs, rfl⟩ := ha_ast + obtain ⟨id2, r2, htl_shape⟩ := mapM_toAst_index_head htl + rw [htl_shape, memberAuxB_field_index, ← htl_shape] at hb + have hev : Cst.Member.evalAccessors head (.field (.idIdent s0 hs0) :: .index ex2 :: rest2) req es + = (do let hv ← getAttr head s0 es; Cst.Member.evalAccessors hv (.index ex2 :: rest2) req es) := by + simp [Cst.Member.evalAccessors, ] + have hstep : evaluate (Expr.getAttr headExpr (s0)) req es + = getAttr head s0 es := by + simp [evaluate, hhead, bind, Except.bind] + rw [hev] + exact evalAccessors_step_eq hstep hb + (fun hv' hge => evalAccessors_eq (.index ex2 :: rest2) tl_ast _ bexp hv' + htl hb hge (fun ce hsz => harg ce (Nat.lt_trans hsz (by simp only [List.cons.sizeOf_spec]; omega)))) + | _ => simp [Cst.MemAccess.toAstAccessor?] at ha_ast +termination_by accs_cst _ _ _ _ _ _ _ _ => accs_cst.length +decreasing_by all_goals (simp_wf <;> omega) + +/-- If a primary translates to a (path-free, function-named) name, it is + syntactically `.name ⟨[], .idIdent s⟩`. -/ +theorem toExprOrSpecial_name_func {item : Cst.Primary} {an : Spec.Name} + (h : item.toExprOrSpecial? = some (.name an)) + (hp : an.path = []) (hf : Cst.String.isFunctionName? an.id = true) : + ∃ s h, item = .name { path := [], name := .idIdent s h } := by + cases item with + | name n => + obtain ⟨npath, nname⟩ := n + simp only [Cst.Primary.toExprOrSpecial?] at h + cases hv : Cst.Name.toVar? ⟨npath, nname⟩ with + | some v => rw [hv] at h; simp at h + | none => + rw [hv] at h + simp only [Option.bind_eq_bind, Option.bind_eq_some_iff, Option.some.injEq, + Cst.ExprOrSpecial.name.injEq] at h + obtain ⟨an', han', rfl⟩ := h + have hagree := Cst.Name.toAName?_agrees han' + rw [hagree] at hp hf + simp only [List.map_eq_nil_iff] at hp + subst hp + cases nname with + | idIdent s hs_kw => exact ⟨s, hs_kw, rfl⟩ + | _ => exact absurd hf (by simp [Cst.Ident.toString, Cst.String.isFunctionName?]) + | literal l => + cases l <;> + simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?, + Option.bind_eq_bind, Option.bind_eq_some_iff] at h + | ref r => + cases r with + | uid path eid => + cases eid with + | string s => + simp [Cst.Primary.toExprOrSpecial?, Cst.Ref.toExprOrSpecial?, + Option.bind_eq_bind, Option.bind_eq_some_iff] at h + | ref a b => + simp [Cst.Primary.toExprOrSpecial?, Cst.Ref.toExprOrSpecial?] at h + | expr e => + simp [Cst.Primary.toExprOrSpecial?, Option.bind_eq_bind, Option.bind_eq_some_iff] at h + | eList es => + simp [Cst.Primary.toExprOrSpecial?, Option.bind_eq_bind, Option.bind_eq_some_iff] at h + | rInits r => + simp [Cst.Primary.toExprOrSpecial?, Option.bind_eq_bind, Option.bind_eq_some_iff] at h + | slot _ => + simp [Cst.Primary.toExprOrSpecial?] at h +/-- `apply₂ .mem` only ever yields a boolean value (or an error), so its result + survives the `.as Bool` coercion the translated `.and` applies to it. -/ +theorem apply₂_mem_returns_bool {v₁ v₂ : Value} {es : Entities} {r : Value} : + apply₂ BinaryOp.mem v₁ v₂ es = .ok r → ∃ b : Bool, r = .prim (.bool b) := by + intro h + simp only [apply₂] at h + split at h <;> simp_all only [reduceCtorEq, Except.ok.injEq, inₛ, bind, Except.bind] + · exact ⟨_, h.symm⟩ + · split at h + · simp at h + · simp only [Except.ok.injEq] at h; exact ⟨_, h.symm⟩ + +/-- For the `rIsIn` case with `inEntity = some ie`: the translated AST evaluates + equally to the applied `in` relation. -/ +theorem rIsIn_some_eval_eq + {target ety ie : Cst.AddExpr} {mt mi : Expr} {et : EntityType} + {req : Request} {es : Entities} + (hEt : ety.toEntityType? = some et) + (htarget_eq : evaluate mt req es = target.evaluate req es) + (hinEntity_eq : evaluate mi req es = ie.evaluate req es) + (hie_trans : ie.toAExpr? = some mi) : + evaluate (Expr.and (.unaryApp (.is et) mt) (.binaryApp .mem mt mi)) req es = + (Cst.Relation.rIsIn target ety (some ie)).evaluate req es := by + simp only [Cst.Relation.evaluate, hEt, evaluate, hie_trans, Option.isNone_some, + Bool.false_eq_true, if_false] + rw [htarget_eq] + cases htgt : target.evaluate req es with + | error e => simp [bind, Except.bind, Result.as] + | ok vt => + simp only [bind, Except.bind] + cases hIs : apply₁ (.is et) vt with + | error e => simp [Result.as] + | ok isVal => + cases isVal with + | prim p => + cases p with + | bool b => + cases b with + | false => simp [Result.as, Coe.coe, Value.asBool] + | true => + simp only [Result.as, Coe.coe, Value.asBool, Bool.not_true, + Bool.false_eq_true, if_false] + rw [hinEntity_eq] + cases hie : ie.evaluate req es with + | error e => simp + | ok v₂ => + cases hmem : apply₂ .mem vt v₂ es with + | error e => simp [hmem] + | ok memv => + have ⟨b', hb'⟩ := apply₂_mem_returns_bool hmem + subst hb' + simp [hmem, pure, Except.pure] + | int _ | string _ | entityUID _ => simp [Result.as, Coe.coe, Value.asBool] + | set _ | record _ | ext _ => simp [Result.as, Coe.coe, Value.asBool] + +/- For AndExpr -/ + +/-- `foldOps` short-circuits on `.bool false`: it ignores `rest` and returns + `.ok (.bool false)`. -/ +theorem andExprFoldOps_false_short_circuits + (req : Request) (es : Entities) (rest : List Cst.Relation) : + Cst.AndExpr.foldOps (.prim (.bool false)) rest req es = .ok (.prim (.bool false)) := by + cases rest with + | nil => simp [Cst.AndExpr.foldOps] + | cons _ _ => simp [Cst.AndExpr.foldOps, Value.asBool, bind, Except.bind] + +/-- Bridge one fold step: `evaluate (Expr.and acc_ast rhs)` followed by + `foldOps ... rest` matches `foldOps acc_v (rel :: rest)`. -/ +theorem expr_and_eval_eq_foldOps_step + (req : Request) (es : Entities) + (acc_ast rhs : Expr) (acc_v : Value) (rel : Cst.Relation) + (rest : List Cst.Relation) : + evaluate acc_ast req es = .ok acc_v → + (∀ vp, evaluate rhs req es = .ok vp ↔ rel.evaluate req es = .ok vp) → + ∀ v, + (do let v' ← evaluate (Expr.and acc_ast rhs) req es + Cst.AndExpr.foldOps v' rest req es) = .ok v ↔ + Cst.AndExpr.foldOps acc_v (rel :: rest) req es = .ok v := by + intro hacc hrel_iff v + simp [Cst.AndExpr.foldOps, evaluate, hacc, bind, Except.bind, Result.as, Coe.coe] + cases hAccBool : acc_v.asBool with + | error _ => simp + | ok bAcc => + cases bAcc with + | false => + simp + rw [andExprFoldOps_false_short_circuits] + exact ⟨fun h => by injection h, fun h => by rw [← h]⟩ + | true => + simp + cases h_rhs : evaluate rhs req es with + | error err => + cases h_rel : rel.evaluate req es with + | ok rv => + have := (hrel_iff rv).mpr h_rel + rw [this] at h_rhs; cases h_rhs + | error err' => simp + | ok rv => + have h_rel_ok : rel.evaluate req es = .ok rv := (hrel_iff rv).mp h_rhs + rw [h_rel_ok] + cases rv with + | prim p => + cases p with + | bool _ => simp [Value.asBool, pure, Except.pure] + | int _ | string _ | entityUID _ => simp [Value.asBool] + | set _ | record _ | ext _ => simp [Value.asBool] + +/-- Equality version of `expr_and_eval_eq_foldOps_step`. -/ +theorem expr_and_eval_eq_foldOps_step_eq + (req : Request) (es : Entities) + (acc_ast rhs : Expr) (acc_v : Value) (rel : Cst.Relation) + (rest : List Cst.Relation) : + evaluate acc_ast req es = .ok acc_v → + evaluate rhs req es = rel.evaluate req es → + (do let v' ← evaluate (Expr.and acc_ast rhs) req es + Cst.AndExpr.foldOps v' rest req es) = + Cst.AndExpr.foldOps acc_v (rel :: rest) req es := by + intro hacc hrel_eq + simp [Cst.AndExpr.foldOps, evaluate, hacc, bind, Except.bind, Result.as, Coe.coe] + cases hAccBool : acc_v.asBool with + | error _ => simp + | ok bAcc => + cases bAcc with + | false => + simp + rw [andExprFoldOps_false_short_circuits] + | true => + simp + rw [hrel_eq] + cases h_rel : rel.evaluate req es with + | error err => simp + | ok rv => + cases rv with + | prim p => + cases p with + | bool _ => simp [Value.asBool, pure, Except.pure] + | int _ | string _ | entityUID _ => simp [Value.asBool] + | set _ | record _ | ext _ => simp [Value.asBool] + +/- For OrExpr -/ + +/-- `foldOps` short-circuits on `.bool true`: it ignores `rest` and returns + `.ok (.bool true)`. -/ +theorem orExprFoldOps_true_short_circuits + (req : Request) (es : Entities) (rest : List Cst.AndExpr) : + Cst.OrExpr.foldOps (.prim (.bool true)) rest req es = .ok (.prim (.bool true)) := by + cases rest with + | nil => simp [Cst.OrExpr.foldOps] + | cons _ _ => simp [Cst.OrExpr.foldOps, Value.asBool, bind, Except.bind] + +/-- Bridge one fold step: `evaluate (Expr.or acc_ast rhs)` followed by + `foldOps ... rest` matches `foldOps acc_v (ande :: rest)`. -/ +theorem expr_or_eval_eq_foldOps_step + (req : Request) (es : Entities) + (acc_ast rhs : Expr) (acc_v : Value) (ande : Cst.AndExpr) + (rest : List Cst.AndExpr) : + evaluate acc_ast req es = .ok acc_v → + (∀ vp, evaluate rhs req es = .ok vp ↔ ande.evaluate req es = .ok vp) → + ∀ v, + (do let v' ← evaluate (Expr.or acc_ast rhs) req es + Cst.OrExpr.foldOps v' rest req es) = .ok v ↔ + Cst.OrExpr.foldOps acc_v (ande :: rest) req es = .ok v := by + intro hacc hrel_iff v + simp [Cst.OrExpr.foldOps, evaluate, hacc, bind, Except.bind, Result.as, Coe.coe] + cases hAccBool : acc_v.asBool with + | error _ => simp + | ok bAcc => + cases bAcc with + | true => + simp + rw [orExprFoldOps_true_short_circuits] + exact ⟨fun h => by injection h, fun h => by rw [← h]⟩ + | false => + simp + cases h_rhs : evaluate rhs req es with + | error err => + cases h_rel : ande.evaluate req es with + | ok rv => + have := (hrel_iff rv).mpr h_rel + rw [this] at h_rhs; cases h_rhs + | error err' => simp + | ok rv => + have h_rel_ok : ande.evaluate req es = .ok rv := (hrel_iff rv).mp h_rhs + rw [h_rel_ok] + cases rv with + | prim p => + cases p with + | bool _ => simp [Value.asBool, pure, Except.pure] + | int _ | string _ | entityUID _ => simp [Value.asBool] + | set _ | record _ | ext _ => simp [Value.asBool] + +/-- Equality version of `expr_or_eval_eq_foldOps_step`. -/ +theorem expr_or_eval_eq_foldOps_step_eq + (req : Request) (es : Entities) + (acc_ast rhs : Expr) (acc_v : Value) (ande : Cst.AndExpr) + (rest : List Cst.AndExpr) : + evaluate acc_ast req es = .ok acc_v → + evaluate rhs req es = ande.evaluate req es → + (do let v' ← evaluate (Expr.or acc_ast rhs) req es + Cst.OrExpr.foldOps v' rest req es) = + Cst.OrExpr.foldOps acc_v (ande :: rest) req es := by + intro hacc hrel_eq + simp [Cst.OrExpr.foldOps, evaluate, hacc, bind, Except.bind, Result.as, Coe.coe] + cases hAccBool : acc_v.asBool with + | error _ => simp + | ok bAcc => + cases bAcc with + | true => + simp + rw [orExprFoldOps_true_short_circuits] + | false => + simp + rw [hrel_eq] + cases h_rel : ande.evaluate req es with + | error err => simp + | ok rv => + cases rv with + | prim p => + cases p with + | bool _ => simp [Value.asBool, pure, Except.pure] + | int _ | string _ | entityUID _ => simp [Value.asBool] + | set _ | record _ | ext _ => simp [Value.asBool] + +/-- `MultExpr.foldExtended` evaluation equality, with the per-`Unary` + evaluation equality supplied as a hypothesis so the fold stays outside the + mutual `_sound` cycle. -/ +theorem multExprFoldExtended_foldOps_eq + (req : Request) (es : Entities) : + (xs : List (Cst.MultOp × Cst.Unary)) → + (∀ p ∈ xs, ∀ (eu : Expr), p.2.toAExpr? = some eu → + evaluate eu req es = p.2.evaluate req es) → + (acc_ast result : Expr) → + Cst.MultExpr.foldExtended acc_ast xs = some result → + evaluate result req es = + (do let acc_v ← evaluate acc_ast req es; Cst.MultExpr.foldOps acc_v xs req es) + | [], _, acc_ast, result, hfold => by + simp [Cst.MultExpr.foldExtended] at hfold + subst hfold + cases h : evaluate acc_ast req es <;> simp [Cst.MultExpr.foldOps, bind, Except.bind] + | (op, u) :: rest, hueq, acc_ast, result, hfold => by + cases hop : op with + | mTimes => + simp [Cst.MultExpr.foldExtended, hop] at hfold + cases hu : u.toAExpr? with + | none => rw [hu] at hfold; simp at hfold + | some eu => + rw [hu] at hfold; simp at hfold + have ih' := multExprFoldExtended_foldOps_eq req es rest + (fun p hp => hueq p (List.mem_cons_of_mem _ hp)) _ _ hfold + rw [ih'] + have hu_eq := hueq (op, u) List.mem_cons_self eu hu + simp [evaluate, Cst.MultExpr.foldOps, bind_assoc, hu_eq] + | _ => simp [Cst.MultExpr.foldExtended, hop] at hfold +termination_by xs _ _ _ => xs.length + +/-- `AddExpr.foldExtended` evaluation equality, with the per-`MultExpr` + evaluation equality supplied as a hypothesis. -/ +theorem addExprFoldExtended_foldOps_eq + (req : Request) (es : Entities) : + (xs : List (Cst.AddOp × Cst.MultExpr)) → + (∀ p ∈ xs, ∀ (em : Expr), p.2.toAExpr? = some em → + evaluate em req es = p.2.evaluate req es) → + (acc_ast result : Expr) → + Cst.AddExpr.foldExtended acc_ast xs = some result → + evaluate result req es = + (do let acc_v ← evaluate acc_ast req es; Cst.AddExpr.foldOps acc_v xs req es) + | [], _, acc_ast, result, hfold => by + simp [Cst.AddExpr.foldExtended] at hfold + subst hfold + cases h : evaluate acc_ast req es <;> simp [Cst.AddExpr.foldOps, bind, Except.bind] + | (op, m) :: rest, hmeq, acc_ast, result, hfold => by + cases hop : op with + | aPlus => + simp [Cst.AddExpr.foldExtended, hop] at hfold + cases hm : m.toAExpr? with + | none => rw [hm] at hfold; simp at hfold + | some em => + rw [hm] at hfold; simp at hfold + have ih' := addExprFoldExtended_foldOps_eq req es rest + (fun p hp => hmeq p (List.mem_cons_of_mem _ hp)) _ _ hfold + rw [ih'] + have hm_eq := hmeq (op, m) List.mem_cons_self em hm + simp [evaluate, Cst.AddExpr.foldOps, bind_assoc, hm_eq] + | aMinus => + simp [Cst.AddExpr.foldExtended, hop] at hfold + cases hm : m.toAExpr? with + | none => rw [hm] at hfold; simp at hfold + | some em => + rw [hm] at hfold; simp at hfold + have ih' := addExprFoldExtended_foldOps_eq req es rest + (fun p hp => hmeq p (List.mem_cons_of_mem _ hp)) _ _ hfold + rw [ih'] + have hm_eq := hmeq (op, m) List.mem_cons_self em hm + simp [evaluate, Cst.AddExpr.foldOps, bind_assoc, hm_eq] +termination_by xs _ _ _ => xs.length + +/-- `AndExpr.foldExtended` evaluation equality, with the per-`Relation` + evaluation equality supplied as a hypothesis. -/ +theorem andExprFoldExtended_foldOps_eq + (req : Request) (es : Entities) : + (xs : List Cst.Relation) → + (∀ r ∈ xs, ∀ (er : Expr), r.toAExpr? = some er → + evaluate er req es = r.evaluate req es) → + (acc_ast result : Expr) → + Cst.AndExpr.foldExtended acc_ast xs = some result → + evaluate result req es = + (do let acc_v ← evaluate acc_ast req es; Cst.AndExpr.foldOps acc_v xs req es) + | [], _, acc_ast, result, hfold => by + simp [Cst.AndExpr.foldExtended] at hfold + subst hfold + cases h : evaluate acc_ast req es <;> simp [Cst.AndExpr.foldOps, bind, Except.bind] + | rel :: rest, hreq, acc_ast, result, hfold => by + simp [Cst.AndExpr.foldExtended] at hfold + cases hrel : rel.toAExpr? with + | none => rw [hrel] at hfold; simp at hfold + | some erel => + rw [hrel] at hfold; simp at hfold + have ih' := andExprFoldExtended_foldOps_eq req es rest + (fun r hr => hreq r (List.mem_cons_of_mem _ hr)) _ _ hfold + rw [ih'] + have hrel_eq := hreq rel List.mem_cons_self erel hrel + cases h_acc : evaluate acc_ast req es with + | error err => simp [evaluate, h_acc, bind, Except.bind, Result.as] + | ok acc_v => + rw [expr_and_eval_eq_foldOps_step_eq req es acc_ast erel acc_v rel rest h_acc hrel_eq] + simp [bind, Except.bind] +termination_by xs _ _ _ => xs.length + +/-- `OrExpr.foldExtended` evaluation equality, with the per-`AndExpr` + evaluation equality supplied as a hypothesis. -/ +theorem orExprFoldExtended_foldOps_eq + (req : Request) (es : Entities) : + (xs : List Cst.AndExpr) → + (∀ a ∈ xs, ∀ (ea : Expr), a.toAExpr? = some ea → + evaluate ea req es = a.evaluate req es) → + (acc_ast result : Expr) → + Cst.OrExpr.foldExtended acc_ast xs = some result → + evaluate result req es = + (do let acc_v ← evaluate acc_ast req es; Cst.OrExpr.foldOps acc_v xs req es) + | [], _, acc_ast, result, hfold => by + simp [Cst.OrExpr.foldExtended] at hfold + subst hfold + cases h : evaluate acc_ast req es <;> simp [Cst.OrExpr.foldOps, bind, Except.bind] + | ande :: rest, hareq, acc_ast, result, hfold => by + simp [Cst.OrExpr.foldExtended] at hfold + cases hande : ande.toAExpr? with + | none => rw [hande] at hfold; simp at hfold + | some eande => + rw [hande] at hfold; simp at hfold + have ih' := orExprFoldExtended_foldOps_eq req es rest + (fun a ha => hareq a (List.mem_cons_of_mem _ ha)) _ _ hfold + rw [ih'] + have hande_eq := hareq ande List.mem_cons_self eande hande + cases h_acc : evaluate acc_ast req es with + | error err => simp [evaluate, h_acc, bind, Except.bind, Result.as] + | ok acc_v => + rw [expr_or_eval_eq_foldOps_step_eq req es acc_ast eande acc_v ande rest h_acc hande_eq] + simp [bind, Except.bind] +termination_by xs _ _ _ => xs.length + +/-- If `foldExtended` succeeds on `xs`, every conjunct in `xs` translates. Used + to discharge the `AndExpr.evaluate` translatability guard. -/ +theorem andExprFoldExtended_some_all_translate (xs : List Cst.Relation) : + ∀ {acc result : Expr}, Cst.AndExpr.foldExtended acc xs = some result → + xs.all (fun r => r.toAExpr?.isSome) = true := by + induction xs with + | nil => intro acc result _; rfl + | cons rel rest ih => + intro acc result h + simp [Cst.AndExpr.foldExtended] at h + cases hrel : rel.toAExpr? with + | none => rw [hrel] at h; simp at h + | some aval => + rw [hrel] at h + simp at h + simp [List.all_cons, hrel, ih h] + +/-- When every conjunct translates, `AndExpr.evaluate`'s guard is a no-op and it + reduces to the plain `initial`-then-`foldOps` evaluation. -/ +theorem AndExpr.evaluate_eq {e : Cst.AndExpr} {req : Request} {es : Entities} + (h : (e.extended.all fun r => r.toAExpr?.isSome) = true) : + Cst.AndExpr.evaluate e req es = + (do let acc ← e.initial.evaluate req es; Cst.AndExpr.foldOps acc e.extended req es) := by + simp only [Cst.AndExpr.evaluate, if_pos h] + +/-- If `foldExtended` succeeds on `xs`, every disjunct in `xs` translates. -/ +theorem orExprFoldExtended_some_all_translate (xs : List Cst.AndExpr) : + ∀ {acc result : Expr}, Cst.OrExpr.foldExtended acc xs = some result → + xs.all (fun r => r.toAExpr?.isSome) = true := by + induction xs with + | nil => intro acc result _; rfl + | cons rel rest ih => + intro acc result h + simp [Cst.OrExpr.foldExtended] at h + cases hrel : rel.toAExpr? with + | none => rw [hrel] at h; simp at h + | some aval => + rw [hrel] at h + simp at h + simp [List.all_cons, hrel, ih h] + +/-- When every disjunct translates, `OrExpr.evaluate`'s guard is a no-op and it + reduces to the plain `initial`-then-`foldOps` evaluation. -/ +theorem OrExpr.evaluate_eq {e : Cst.OrExpr} {req : Request} {es : Entities} + (h : (e.extended.all fun r => r.toAExpr?.isSome) = true) : + Cst.OrExpr.evaluate e req es = + (do let acc ← e.initial.evaluate req es; Cst.OrExpr.foldOps acc e.extended req es) := by + simp only [Cst.OrExpr.evaluate, if_pos h] + +/-- When both branches translate, `ExprData.evaluate`'s `edIf` guard is a no-op + and it reduces to the plain conditional evaluation. -/ +theorem ExprData.evaluate_edIf_eq {i t f : Cst.Expr} {req : Request} {es : Entities} + (h : (t.toAExpr?.isSome && f.toAExpr?.isSome) = true) : + Cst.ExprData.evaluate (.edIf i t f) req es = + (do let b ← (i.evaluate req es).as Bool; + if b then t.evaluate req es else f.evaluate req es) := by + simp only [Cst.ExprData.evaluate, if_pos h] + +/- For Primary's eList case -/ + +/-- Generic element-wise bridge: when each element of `xs` translates to an AST + expression and the per-element iff holds, then evaluating the translated + list element-wise agrees with evaluating the original list element-wise. + The signature uses `.val` form to match `List.mapM₁_eq_mapM`. -/ +theorem mapM_eval_agrees + (req : Request) (es : Entities) : + ∀ (xs : List Cst.Expr) (aes : List Expr), + xs.mapM₁ (fun x => x.val.toAExpr?) = some aes → + (∀ x ∈ xs, ∀ ax, + x.toAExpr? = some ax → + ∀ v, evaluate ax req es = .ok v ↔ x.evaluate req es = .ok v) → + ∀ vs, aes.mapM (fun a => evaluate a req es) = .ok vs ↔ + xs.mapM (fun x => x.evaluate req es) = .ok vs := by + intro xs aes htrans hperElt vs + rw [List.mapM₁_eq_mapM (fun (x : Cst.Expr) => x.toAExpr?)] at htrans + induction xs generalizing aes vs with + | nil => + simp [List.mapM_nil] at htrans + subst htrans + simp [List.mapM_nil] + | cons hd tl ih => + simp [List.mapM_cons, Option.bind_eq_some_iff] at htrans + obtain ⟨ahd, hahd, atl, hatl, haes⟩ := htrans + subst haes + have hhd_iff : ∀ vp, evaluate ahd req es = .ok vp ↔ hd.evaluate req es = .ok vp := + hperElt hd List.mem_cons_self ahd hahd + have htl_perElt : ∀ x ∈ tl, ∀ ax, + x.toAExpr? = some ax → + ∀ v, evaluate ax req es = .ok v ↔ x.evaluate req es = .ok v := by + intro x hx ax hax v + exact hperElt x (List.mem_cons_of_mem _ hx) ax hax v + have ih' := ih atl hatl htl_perElt + simp [List.mapM_cons, bind, Except.bind] + cases hev_ahd : evaluate ahd req es with + | error err => + cases hev_hd : hd.evaluate req es with + | ok vp => + have := (hhd_iff vp).mpr hev_hd + rw [this] at hev_ahd; cases hev_ahd + | error _ => simp + | ok ahdv => + have hev_hd : hd.evaluate req es = .ok ahdv := (hhd_iff ahdv).mp hev_ahd + rw [hev_hd] + simp + cases hev_atl : atl.mapM (fun a => evaluate a req es) with + | error err => + cases hev_tl : tl.mapM (fun x => x.evaluate req es) with + | ok vstl => + have := (ih' vstl).mpr hev_tl + rw [this] at hev_atl; cases hev_atl + | error _ => simp + | ok atlvs => + have hev_tl : tl.mapM (fun x => x.evaluate req es) = .ok atlvs := + (ih' atlvs).mp hev_atl + rw [hev_tl] + +/-- Equality analog of `mapM_eval_agrees`: given per-element *equality* of AST + and CST evaluation, the two `mapM`s are equal (error or `ok`). -/ +theorem mapM_eval_eq + (req : Request) (es : Entities) : + ∀ (xs : List Cst.Expr) (aes : List Expr), + xs.mapM₁ (fun x => x.val.toAExpr?) = some aes → + (∀ x ∈ xs, ∀ ax, + x.toAExpr? = some ax → + evaluate ax req es = x.evaluate req es) → + aes.mapM (fun a => evaluate a req es) = xs.mapM (fun x => x.evaluate req es) := by + intro xs aes htrans hperElt + rw [List.mapM₁_eq_mapM (fun (x : Cst.Expr) => x.toAExpr?)] at htrans + induction xs generalizing aes with + | nil => + simp [List.mapM_nil] at htrans + subst htrans + simp [List.mapM_nil] + | cons hd tl ih => + simp [List.mapM_cons, Option.bind_eq_some_iff] at htrans + obtain ⟨ahd, hahd, atl, hatl, haes⟩ := htrans + subst haes + have hhd_eq := hperElt hd List.mem_cons_self ahd hahd + have htl_perElt : ∀ x ∈ tl, ∀ ax, + x.toAExpr? = some ax → + evaluate ax req es = x.evaluate req es := by + intro x hx ax hax + exact hperElt x (List.mem_cons_of_mem _ hx) ax hax + have ih' := ih atl hatl htl_perElt + simp only [List.mapM_cons] + rw [hhd_eq, ih'] + +/-- `toAExprs?` is `mapM` of `toAExpr?`. -/ +theorem toAExprs?_eq_mapM (args : List Cst.Expr) : + Cst.Expr.toAExprs? args = args.mapM (fun ce => ce.toAExpr?) := by + induction args with + | nil => simp [Cst.Expr.toAExprs?, List.mapM_nil] + | cons ce rest ih => simp [Cst.Expr.toAExprs?, List.mapM_cons, ih] + +/-- Argument-list agreement (evaluation equality): evaluating the AST args + equals evaluating the CST args. -/ +theorem toAExprs?_eval_eq {req : Request} {es : Entities} + (args : List Cst.Expr) (xs : List Expr) + (htr : Cst.Expr.toAExprs? args = some xs) + (harg : ∀ ce ∈ args, ∀ ax, ce.toAExpr? = some ax → + evaluate ax req es = ce.evaluate req es) : + xs.mapM (fun a => evaluate a req es) = args.mapM (fun ce => ce.evaluate req es) := by + apply mapM_eval_eq req es args xs ?_ harg + simp only [List.mapM₁_eq_mapM (fun ce : Cst.Expr => ce.toAExpr?), ← toAExprs?_eq_mapM] + exact htr + +/- Lifting round-trips and entity-UID translation agreement -/ + +/- For Primary's rInits (record) case -/ + +/-- The CST-native record-key attribute extractor on a `Primary` agrees with the + translator's `toExprOrSpecial? >>= toValidAttr?`. -/ +theorem Cst.Primary.toAttr?_consistent (p : Cst.Primary) : + Cst.Primary.toAttr? p = p.toExprOrSpecial?.bind Cst.ExprOrSpecial.toValidAttr? := by + cases p with + | literal l => + cases l with + | liTrue | liFalse | liStr s => + simp [Cst.Primary.toAttr?, Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?, + Cst.ExprOrSpecial.toValidAttr?] + | liNum n => + simp [Cst.Primary.toAttr?, Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?, + Option.bind] + cases Int64.ofInt? (n.toNat : Int) <;> simp [Cst.ExprOrSpecial.toValidAttr?] + | name n => + obtain ⟨path, name⟩ := n + cases path with + | nil => + cases name <;> + simp [Cst.Primary.toAttr?, Cst.Ident.toAttr?, Cst.Primary.toExprOrSpecial?, Cst.Name.toVar?, + Cst.Name.toAName?, Cst.Name.toAName?, + Cst.Ident.toUnrestrictedString?, Cst.ExprOrSpecial.toValidAttr?, + Cst.varToString] + | cons hd tl => + simp only [Cst.Primary.toAttr?, Cst.Primary.toExprOrSpecial?, Cst.Name.toVar?, + List.isEmpty_cons, Bool.not_false, ite_true] + cases hAN : Cst.Name.toAName? ⟨hd :: tl, name⟩ with + | none => simp + | some an => + have heq := Cst.Name.toAName?_agrees hAN + simp [Cst.ExprOrSpecial.toValidAttr?, heq] + | ref r => + cases r with + | uid path eid => + cases eid with + | string s => + simp [Cst.Primary.toAttr?, Cst.Primary.toExprOrSpecial?, Cst.Ref.toExprOrSpecial?, + Option.bind] + cases (Cst.Name.toAName? path) <;> + cases (Cst.unescape? s) <;> simp [Cst.ExprOrSpecial.toValidAttr?] + | ref _ _ => + simp [Cst.Primary.toAttr?, Cst.Primary.toExprOrSpecial?, Cst.Ref.toExprOrSpecial?] + | expr e => + simp [Cst.Primary.toAttr?, Cst.Primary.toExprOrSpecial?, Option.bind] + cases (e.toAExpr?) <;> simp [Cst.ExprOrSpecial.toValidAttr?] + | eList es => + simp [Cst.Primary.toAttr?, Cst.Primary.toExprOrSpecial?, Option.bind] + cases (es.mapM₁ (fun x => x.val.toAExpr?)) <;> simp [Cst.ExprOrSpecial.toValidAttr?] + | rInits r => + simp [Cst.Primary.toAttr?, Cst.Primary.toExprOrSpecial?, Option.bind] + cases (Cst.rInitsToMap? r) <;> simp [Cst.ExprOrSpecial.toValidAttr?] + | slot _ => + simp [Cst.Primary.toAttr?, Cst.Primary.toExprOrSpecial?] +/-- The CST-native record-key attribute extractor on an `Expr` agrees with the + translator's `toExprOrSpecial? >>= toValidAttr?`. Peeling lemma: the key must + reduce to a bare primary; analogous to the `addExpr_to*_agrees` peeling proofs. -/ +theorem Cst.Expr.toAttr?_consistent (e : Cst.Expr) : + Cst.Expr.toAttr? e = e.toExprOrSpecial?.bind Cst.ExprOrSpecial.toValidAttr? := by + match e with + | .expr ⟨.edIf i t f⟩ => + simp only [Cst.Expr.toAttr?, Cst.Expr.toExprOrSpecial?, Cst.ExprImpl.toExprOrSpecial?, + Cst.ExprData.toExprOrSpecial?] + cases i.toAExpr? <;> cases t.toAExpr? <;> cases f.toAExpr? <;> + simp [Cst.ExprOrSpecial.toValidAttr?] + | .expr ⟨.edOr o⟩ => + have hred : Cst.Expr.toExprOrSpecial? (.expr ⟨.edOr o⟩) = o.toExprOrSpecial? := by + simp [Cst.Expr.toExprOrSpecial?, Cst.ExprImpl.toExprOrSpecial?, Cst.ExprData.toExprOrSpecial?] + rw [hred] + cases hoe : o.extended with + | cons _ _ => + simp only [Cst.Expr.toAttr?, hoe, List.isEmpty_cons, Bool.not_false, Bool.true_or, if_true] + rw [Cst.OrExpr.toExprOrSpecial?, hoe] + simp [Cst.ExprOrSpecial.toValidAttr?, Option.bind_assoc] + | nil => + rw [Cst.OrExpr.toExprOrSpecial?, hoe] + cases hae : o.initial.extended with + | cons _ _ => + simp only [Cst.Expr.toAttr?, hoe, hae, List.isEmpty_nil, List.isEmpty_cons, + Bool.not_true, Bool.not_false, Bool.or_true, if_true] + rw [Cst.AndExpr.toExprOrSpecial?, hae] + simp [Cst.ExprOrSpecial.toValidAttr?, Option.bind_assoc] + | nil => + rw [Cst.AndExpr.toExprOrSpecial?, hae] + cases hrel : o.initial.initial with + | rHas tgt fld => + have hL : Cst.Expr.toAttr? (.expr ⟨.edOr o⟩) = none := by + simp [Cst.Expr.toAttr?, hoe, hae, hrel] + rw [hL, Cst.Relation.toExprOrSpecial?] + cases tgt.toAExpr? with + | none => simp + | some t => + cases fld.toHasRhs? with + | none => simp + | some mf => cases mf <;> simp [Cst.ExprOrSpecial.toValidAttr?] + | rLike tgt pat => + have hL : Cst.Expr.toAttr? (.expr ⟨.edOr o⟩) = none := by + simp [Cst.Expr.toAttr?, hoe, hae, hrel] + rw [hL, Cst.Relation.toExprOrSpecial?] + cases tgt.toAExpr? with + | none => simp + | some t => cases pat.toPattern? <;> simp [Cst.ExprOrSpecial.toValidAttr?] + | rIsIn tgt ety inE => + have hL : Cst.Expr.toAttr? (.expr ⟨.edOr o⟩) = none := by + simp [Cst.Expr.toAttr?, hoe, hae, hrel] + rw [hL, Cst.Relation.toExprOrSpecial?] + cases tgt.toAExpr? with + | none => simp + | some t => + cases ety.toEntityType? with + | none => simp + | some et => + cases inE with + | none => simp [Cst.ExprOrSpecial.toValidAttr?] + | some ie => cases ie.toAExpr? <;> simp [Cst.ExprOrSpecial.toValidAttr?, Option.bind_assoc] + | rCommon ae ext => + cases hext : ext with + | cons hd tl => + have hL : Cst.Expr.toAttr? (.expr ⟨.edOr o⟩) = none := by + simp [Cst.Expr.toAttr?, hoe, hae, hrel, hext] + rw [hL] + cases tl with + | cons _ _ => simp [Cst.Relation.toExprOrSpecial?] + | nil => + simp [Cst.Relation.toExprOrSpecial?, Cst.ExprOrSpecial.toValidAttr?, Option.bind_assoc] + | nil => + cases hax : ae.extended with + | cons _ _ => + have hL : Cst.Expr.toAttr? (.expr ⟨.edOr o⟩) = none := by + simp [Cst.Expr.toAttr?, hoe, hae, hrel, hext, hax] + rw [hL] + simp [Cst.Relation.toExprOrSpecial?, Cst.AddExpr.toExprOrSpecial?, hax, + Cst.ExprOrSpecial.toValidAttr?, Option.bind_assoc] + | nil => + cases hmx : ae.initial.extended with + | cons _ _ => + have hL : Cst.Expr.toAttr? (.expr ⟨.edOr o⟩) = none := by + simp [Cst.Expr.toAttr?, hoe, hae, hrel, hext, hax, hmx] + rw [hL] + simp [Cst.Relation.toExprOrSpecial?, Cst.AddExpr.toExprOrSpecial?, + Cst.MultExpr.toExprOrSpecial?, hax, hmx, Cst.ExprOrSpecial.toValidAttr?, + Option.bind_assoc] + | nil => + have hredRel : (Cst.Relation.rCommon ae []).toExprOrSpecial? + = ae.initial.initial.toExprOrSpecial? := by + simp [Cst.Relation.toExprOrSpecial?, Cst.AddExpr.toExprOrSpecial?, + Cst.MultExpr.toExprOrSpecial?, hax, hmx] + rw [hredRel, Cst.Unary.toExprOrSpecial?] + cases hop : ae.initial.initial.op with + | none => + cases hacc : ae.initial.initial.item.access with + | nil => + have hL : Cst.Expr.toAttr? (.expr ⟨.edOr o⟩) + = Cst.Primary.toAttr? ae.initial.initial.item.item := by + simp [Cst.Expr.toAttr?, hoe, hae, hrel, hext, hax, hmx, hacc, hop] + rw [hL, Cst.Member.toExprOrSpecial?, hacc] + simp [List.mapM_nil, Cst.memberAuxA, Cst.memberAux, Cst.Primary.toAttr?_consistent] + | cons hd tl => + have hL : Cst.Expr.toAttr? (.expr ⟨.edOr o⟩) = none := by + simp [Cst.Expr.toAttr?, hoe, hae, hrel, hext, hax, hmx, hacc] + rw [hL] + exact (member_nonempty_validAttr (by rw [hacc]; simp)).symm + | some np => + cases np with + | nDash n => + by_cases hn : n = 0 + · subst hn + cases hacc : ae.initial.initial.item.access with + | nil => + have hL : Cst.Expr.toAttr? (.expr ⟨.edOr o⟩) + = Cst.Primary.toAttr? ae.initial.initial.item.item := by + simp [Cst.Expr.toAttr?, hoe, hae, hrel, hext, hax, hmx, hacc, hop] + rw [hL, Cst.Member.toExprOrSpecial?, hacc] + simp [List.mapM_nil, Cst.memberAuxA, Cst.memberAux, Cst.Primary.toAttr?_consistent] + | cons hd tl => + have hL : Cst.Expr.toAttr? (.expr ⟨.edOr o⟩) = none := by + simp [Cst.Expr.toAttr?, hoe, hae, hrel, hext, hax, hmx, hacc] + rw [hL] + exact (member_nonempty_validAttr (by rw [hacc]; simp)).symm + · have hL : Cst.Expr.toAttr? (.expr ⟨.edOr o⟩) = none := by + simp [Cst.Expr.toAttr?, hoe, hae, hrel, hext, hax, hmx, hop, hn] + rw [hL] + simp + repeat' split + all_goals simp [Cst.ExprOrSpecial.toValidAttr?, Option.bind_assoc] + | nBang n => + have hL : Cst.Expr.toAttr? (.expr ⟨.edOr o⟩) = none := by + simp [Cst.Expr.toAttr?, hoe, hae, hrel, hext, hax, hmx, hop] + rw [hL] + simp [Cst.ExprOrSpecial.toValidAttr?, Option.bind_assoc] + + +/-- Record-level bridge (evaluation equality): when `rInitsToMap? r = some map`, + evaluating the translated inits equals evaluating the CST record inits. -/ +theorem rInits_eval_eq (req : Request) (es : Entities) : + ∀ (r : List Cst.RecInit) (map : List (Attr × Expr)), + Cst.rInitsToMap? r = some map → + (∀ ri ∈ r, ∀ ax, ri.value.toAExpr? = some ax → + evaluate ax req es = ri.value.evaluate req es) → + map.mapM (fun x => bindAttr x.fst (evaluate x.snd req es)) = + r.mapM (fun ri => + match ri.attr.toAttr? with + | none => Except.error (Error.cstError CstError.stringError) + | some attr => do let val ← ri.value.evaluate req es; .ok (attr, val)) := by + intro r + induction r with + | nil => + intro map hmap _ + simp [Cst.rInitsToMap?] at hmap + subst hmap + simp [List.mapM_nil] + | cons ri rs ih => + intro map hmap hperElt + simp [Cst.rInitsToMap?, Option.bind_eq_some_iff] at hmap + obtain ⟨attr_eos, hattr_eos, attr, hattr, vexpr, hvexpr, rest, hrest, hmapeq⟩ := hmap + subst hmapeq + have hkey : ri.attr.toAttr? = some attr := by + rw [Cst.Expr.toAttr?_consistent, hattr_eos]; simpa using hattr + have hhd_eq : evaluate vexpr req es = ri.value.evaluate req es := + hperElt ri List.mem_cons_self vexpr hvexpr + have htl_perElt : ∀ x ∈ rs, ∀ ax, x.value.toAExpr? = some ax → + evaluate ax req es = x.value.evaluate req es := fun x hx ax hax => + hperElt x (List.mem_cons_of_mem _ hx) ax hax + have ih' := ih rest hrest htl_perElt + have hhead : bindAttr attr (evaluate vexpr req es) + = (do let val ← ri.value.evaluate req es; Except.ok (attr, val)) := by + rw [hhd_eq]; simp [bindAttr, bind, Except.bind, pure, Except.pure] + simp only [List.mapM_cons, hkey] + rw [hhead, ih'] + +/-- Evaluate-level record bridge (evaluation equality): the translated AST record + `Expr.record map` evaluates as the CST record does. -/ +theorem rInits_record_eval_eq (req : Request) (es : Entities) + (r : List Cst.RecInit) (map : List (Attr × Expr)) + (hmap : Cst.rInitsToMap? r = some map) + (hperElt : ∀ ri ∈ r, ∀ ax, ri.value.toAExpr? = some ax → + evaluate ax req es = ri.value.evaluate req es) : + evaluate (Expr.record map) req es = (Cst.Primary.rInits r).evaluate req es := by + have hbridge := rInits_eval_eq req es r map hmap hperElt + have hAST : evaluate (Expr.record map) req es = + (map.mapM (fun x => bindAttr x.fst (evaluate x.snd req es))) >>= + fun avs => Except.ok (Value.record (Map.make avs)) := by + simp only [evaluate, List.mapM₂_eq_mapM (fun x => bindAttr x.fst (evaluate x.snd req es))] + have hCST : (Cst.Primary.rInits r).evaluate req es = + (r.mapM (fun ri => + match ri.attr.toAttr? with + | none => Except.error (Error.cstError CstError.stringError) + | some attr => do let val ← ri.value.evaluate req es; Except.ok (attr, val))) >>= + fun avs => Except.ok (Value.record (Map.make avs)) := by + simp only [Cst.Primary.evaluate] + congr 1 + exact List.mapM₁_eq_mapM (fun ri : Cst.RecInit => + match ri.attr.toAttr? with + | none => Except.error (Error.cstError CstError.stringError) + | some attr => do let val ← ri.value.evaluate req es; Except.ok (attr, val)) r + rw [hAST, hCST, hbridge] + +/-- Lifting a CST expr to a `Relation` and translating round-trips. -/ +theorem toRelation_toAExpr (e : Cst.Expr) : + (Cst.Expr.toRelation e).toAExpr? = e.toAExpr? := by + simp [Cst.Expr.toRelation, Cst.Expr.toPrimary, Cst.Primary.toMember, + Cst.Member.toUnary, Cst.Unary.toMultExpr, Cst.MultExpr.toAddExpr, Cst.AddExpr.toRelation, + Cst.Relation.toAExpr?, Cst.Relation.toExprOrSpecial?, Cst.AddExpr.toExprOrSpecial?, + Cst.MultExpr.toExprOrSpecial?, Cst.Unary.toExprOrSpecial?, Cst.Member.toExprOrSpecial?, + Cst.Primary.toExprOrSpecial?, Cst.memberAuxA, Cst.memberAux, Cst.ExprOrSpecial.toExpr?, + Cst.Expr.toAExpr?, Option.bind_assoc] + +/-- Lifting a CST expr to an `AddExpr` and translating round-trips. -/ +theorem toAddExpr_toAExpr (e : Cst.Expr) : + (Cst.Expr.toAddExpr e).toAExpr? = e.toAExpr? := by + simp [Cst.Expr.toAddExpr, Cst.Expr.toPrimary, Cst.Primary.toMember, + Cst.Member.toUnary, Cst.Unary.toMultExpr, Cst.MultExpr.toAddExpr, + Cst.AddExpr.toAExpr?, Cst.AddExpr.toExprOrSpecial?, Cst.MultExpr.toExprOrSpecial?, + Cst.Unary.toExprOrSpecial?, Cst.Member.toExprOrSpecial?, Cst.Primary.toExprOrSpecial?, + Cst.memberAuxA, Cst.memberAux, Cst.ExprOrSpecial.toExpr?, Cst.Expr.toAExpr?, Option.bind_assoc] + +/- The entity-UID extractor agrees with the AST translation on the produced + expression: a `Primary`/`Expr` that `toMultipleEntityUID?` reads as a single + UID (or list of UIDs) translates (via `toAExpr?`) to the corresponding entity + literal (or set of entity literals). -/ +def memToExpr : EntityUID ⊕ List EntityUID → Expr + | .inl uid => .lit (.entityUID uid) + | .inr uids => .set (uids.map (fun u => .lit (.entityUID u))) + +mutual +theorem prim_mem_toAExpr {p : Cst.Primary} {r : EntityUID ⊕ List EntityUID} : + p.toMultipleEntityUID? = some r → p.toAExpr? = some (memToExpr r) := by + intro h + cases p with + | literal _ => simp [Cst.Primary.toMultipleEntityUID?] at h + | name _ => simp [Cst.Primary.toMultipleEntityUID?] at h + | ref rf => + cases rf with + | uid path eid => + cases eid with + | string s => + simp [Cst.Primary.toMultipleEntityUID?, Option.bind_eq_some_iff] at h + obtain ⟨p', hp', eid', heid', heq⟩ := h + subst heq + simp [Cst.Primary.toAExpr?, Cst.Primary.toExprOrSpecial?, Cst.Ref.toExprOrSpecial?, + hp', heid', Cst.ExprOrSpecial.toExpr?, memToExpr] + | ref _ _ => simp [Cst.Primary.toMultipleEntityUID?] at h + | expr e' => + simp only [Cst.Primary.toMultipleEntityUID?] at h + have hih := expr_mem_toAExpr h + simp [Cst.Primary.toAExpr?, Cst.Primary.toExprOrSpecial?, Cst.ExprOrSpecial.toExpr?, + Cst.Expr.toAExpr?, Option.bind_assoc] at hih ⊢ + exact hih + | eList es => + simp [Cst.Primary.toMultipleEntityUID?, Option.bind_eq_some_iff] at h + obtain ⟨uids, huids, heq⟩ := h + subst heq + have hlist := list_mem_toAExpr huids + unfold Cst.Primary.toAExpr? Cst.Primary.toExprOrSpecial? + rw [List.mapM₁_eq_mapM (fun x : Cst.Expr => x.toAExpr?), hlist] + simp [Cst.ExprOrSpecial.toExpr?, memToExpr] + | rInits _ => + simp [Cst.Primary.toMultipleEntityUID?] at h + | slot _ => + simp [Cst.Primary.toMultipleEntityUID?] at h +termination_by (sizeOf p, 0) +decreasing_by all_goals (simp_wf; first | assumption | decreasing_tactic) + +theorem expr_mem_toAExpr {e : Cst.Expr} {r : EntityUID ⊕ List EntityUID} : + e.toMultipleEntityUID? = some r → e.toAExpr? = some (memToExpr r) := by + intro h + match he : e with + | .expr ⟨.edIf _ _ _⟩ => simp [Cst.Expr.toMultipleEntityUID?] at h + | .expr ⟨.edOr o⟩ => + simp only [Cst.Expr.toMultipleEntityUID?] at h + split at h + · simp at h + · rename_i hc1 + split at h <;> try simp at h + rename_i ae ext heq + simp at hc1 + obtain ⟨hoext, hoiext⟩ := hc1 + obtain ⟨⟨⟨⟨⟨hext, haeext⟩, hmext⟩, hop⟩, hacc⟩, hinner⟩ := h + have hsz : sizeOf ae.initial.initial.item.item < sizeOf e := by + have h1 := Cst.sizeOf_addExpr_primary_lt_orExpr o ae ext heq + have h2 : sizeOf o < sizeOf e := by rw [he]; decreasing_tactic + exact Nat.lt_trans h1 h2 + have hih := prim_mem_toAExpr hinner + simp [Cst.Expr.toAExpr?, Cst.Expr.toExprOrSpecial?, Cst.ExprImpl.toExprOrSpecial?, + Cst.ExprData.toExprOrSpecial?, Cst.OrExpr.toExprOrSpecial?, hoext, hoiext, heq, + Cst.AndExpr.toExprOrSpecial?, Cst.Relation.toExprOrSpecial?, hext, + Cst.AddExpr.toExprOrSpecial?, haeext, Cst.MultExpr.toExprOrSpecial?, hmext, + Cst.Unary.toExprOrSpecial?, hop, Cst.Member.toExprOrSpecial?, hacc, Cst.memberAuxA, Cst.memberAux, + Cst.Primary.toAExpr?] at hih ⊢ + exact hih +termination_by (sizeOf e, 1) +decreasing_by all_goals (simp_wf; first | assumption | decreasing_tactic) + +theorem list_mem_toAExpr {es : List Cst.Expr} {uids : List EntityUID} : + es.mapM (fun x => match x.toMultipleEntityUID? with | some (.inl e) => some e | _ => none) = some uids → + es.mapM (fun x => x.toAExpr?) = some (uids.map (fun u => Expr.lit (.entityUID u))) := by + intro h + cases es with + | nil => simp_all + | cons x xs => + rw [List.mapM_cons] at h + simp [Option.bind_eq_some_iff] at h + obtain ⟨eref, href, restU, hrest, rfl⟩ := h + have hxm : x.toMultipleEntityUID? = some (.inl eref) := by + cases hx : x.toMultipleEntityUID? with + | none => rw [hx] at href; simp at href + | some rr => + cases rr with + | inl e => rw [hx] at href; simp at href; subst href; rfl + | inr _ => rw [hx] at href; simp at href + have hxa := expr_mem_toAExpr hxm + have hxsa := list_mem_toAExpr hrest + simp [List.mapM_cons, hxa, hxsa, memToExpr] +termination_by (sizeOf es, 2) +decreasing_by all_goals (simp_wf; first | assumption | decreasing_tactic) +end + +/- Forward translation helpers (used by the policy-translation soundness proof) -/ + +/-- `toEntityUID?` agrees with the AST translation on the produced literal. -/ +theorem toEntityUID_toAExpr {e : Cst.Expr} {uid : EntityUID} : + e.toEntityUID? = some uid → e.toAExpr? = some (.lit (.entityUID uid)) := by + intro h + simp [Cst.Expr.toEntityUID?, Option.bind_eq_some_iff] at h + obtain ⟨erefs, herefs, hmatch⟩ := h + cases erefs with + | inl eref => simp only [Option.some.injEq] at hmatch; subst hmatch; exact expr_mem_toAExpr herefs + | inr _ => simp at hmatch + +/-- `Cst.Expr.not` translates to an AST `.not`. -/ +theorem cond_not_toAExpr {e : Cst.Expr} {b : Expr} : + e.toAExpr? = some b → (Cst.Expr.not e).toAExpr? = some (Expr.unaryApp .not b) := by + intro h + simp [Cst.Expr.not, Cst.Expr.toPrimary, Cst.Primary.toMember, + Cst.Unary.toMultExpr, Cst.MultExpr.toAddExpr, Cst.AddExpr.toRelation, Cst.Relation.toAndExpr, + Cst.AndExpr.toOrExpr, Cst.OrExpr.toExpr, Cst.Expr.toAExpr?, Cst.Expr.toExprOrSpecial?, + Cst.ExprImpl.toExprOrSpecial?, Cst.ExprData.toExprOrSpecial?, Cst.OrExpr.toExprOrSpecial?, + Cst.AndExpr.toExprOrSpecial?, Cst.Relation.toExprOrSpecial?, Cst.AddExpr.toExprOrSpecial?, + Cst.MultExpr.toExprOrSpecial?, Cst.Unary.toExprOrSpecial?, Cst.Member.toExprOrSpecial?, + Cst.Primary.toExprOrSpecial?, Cst.memberAuxA, Cst.memberAux, Cst.bangN, Cst.ExprOrSpecial.toExpr?, h] + +/-- If both halves of an append `mapM`-translate, so does the whole list. -/ +theorem mapM_append_isSome {α β : Type} {f : α → Option β} : + ∀ {l1 l2 : List α}, + (∃ r1, l1.mapM f = some r1) → (∃ r2, l2.mapM f = some r2) → + ∃ r, (l1 ++ l2).mapM f = some r := by + intro l1 l2 h1 h2 + obtain ⟨r1, hr1⟩ := h1 + obtain ⟨r2, hr2⟩ := h2 + induction l1 generalizing r1 with + | nil => + simp only [List.nil_append] + exact ⟨r2, hr2⟩ + | cons hd tl ih => + simp [List.mapM_cons, Option.bind_eq_some_iff] at hr1 + obtain ⟨b, hb, rest, hrest, _⟩ := hr1 + obtain ⟨r, hr⟩ := ih rest hrest + refine ⟨b :: r, ?_⟩ + rw [List.cons_append] + simp [List.mapM_cons, hb, hr] + +/-- Collapsing a single-relation `AndExpr` through the translation chain. -/ +theorem andExpr_single_collapse (r : Cst.Relation) : + ({initial := r, extended := []} : Cst.AndExpr).toOrExpr.toExpr.toAExpr? = r.toAExpr? := by + simp [Cst.AndExpr.toOrExpr, Cst.OrExpr.toExpr, Cst.Expr.toAExpr?, Cst.Expr.toExprOrSpecial?, + Cst.ExprImpl.toExprOrSpecial?, Cst.ExprData.toExprOrSpecial?, Cst.OrExpr.toExprOrSpecial?, + Cst.AndExpr.toExprOrSpecial?, Cst.Relation.toAExpr?] + +/-- Forward leaf translation for principal/resource scope variables: when + `toPRScope?` succeeds and the variable translates to an `Expr.var`, the + variable definition's expression translates to AST. -/ +theorem toPRScope_leaf_isSome {vd : Cst.VariableDef} {scope : Scope} {v : Var} + (hv : (vd.var.varToAddExpr).toExprOrSpecial? = some (Cst.ExprOrSpecial.var v)) + (hscope : vd.toPRScope? = some scope) : + ∃ leaf, vd.toExpr.toAExpr? = some leaf := by + have hv2 : (vd.var.varToAddExpr).toAExpr? = some (Expr.var v) := by + simp [Cst.AddExpr.toAExpr?, hv, Cst.ExprOrSpecial.toExpr?] + obtain ⟨var, et, ineq⟩ := vd + simp only [Cst.VariableDef.toExpr, Cst.VariableDef.toAndExpr] + match ineq, et, hscope with + | none, none, hscope => + rw [andExpr_single_collapse] + simp [Cst.Relation.tt, Cst.Primary.toMember, Cst.Member.toUnary, Cst.Unary.toMultExpr, + Cst.MultExpr.toAddExpr, Cst.AddExpr.toRelation, Cst.Relation.toAExpr?, + Cst.Relation.toExprOrSpecial?, Cst.AddExpr.toExprOrSpecial?, Cst.MultExpr.toExprOrSpecial?, + Cst.Unary.toExprOrSpecial?, Cst.Member.toExprOrSpecial?, Cst.Primary.toExprOrSpecial?, + Cst.Literal.toExprOrSpecial?, Cst.memberAuxA, Cst.memberAux, Cst.ExprOrSpecial.toExpr?] + | none, some t, hscope => + simp [Cst.VariableDef.toPRScope?, Option.bind_eq_some_iff] at hscope + obtain ⟨ety, hety, _⟩ := hscope + rw [andExpr_single_collapse] + simp [Cst.Relation.toAExpr?, Cst.Relation.toExprOrSpecial?, hv2, hety, + Cst.ExprOrSpecial.toExpr?] + | some (.rEq, e), none, hscope => + simp [Cst.VariableDef.toPRScope?, Option.bind_eq_some_iff] at hscope + obtain ⟨uid, huid, _⟩ := hscope + rw [andExpr_single_collapse] + simp [Cst.Relation.toAExpr?, Cst.Relation.toExprOrSpecial?, hv, Cst.constructExprRel, + toAddExpr_toAExpr, toEntityUID_toAExpr huid, Cst.ExprOrSpecial.toExpr?] + | some (.rIn, e), none, hscope => + simp [Cst.VariableDef.toPRScope?, Option.bind_eq_some_iff] at hscope + obtain ⟨uid, huid, _⟩ := hscope + rw [andExpr_single_collapse] + simp [Cst.Relation.toAExpr?, Cst.Relation.toExprOrSpecial?, hv, Cst.constructExprRel, + toAddExpr_toAExpr, toEntityUID_toAExpr huid, Cst.ExprOrSpecial.toExpr?] + | some (.rIn, e), some t, hscope => + simp [Cst.VariableDef.toPRScope?, Option.bind_eq_some_iff] at hscope + obtain ⟨uid, huid, ety, hety, _⟩ := hscope + rw [andExpr_single_collapse] + simp [Cst.Relation.toAExpr?, Cst.Relation.toExprOrSpecial?, hv2, hety, + toAddExpr_toAExpr, toEntityUID_toAExpr huid, Cst.ExprOrSpecial.toExpr?] + | some (.rEq, e), some t, hscope => simp [Cst.VariableDef.toPRScope?] at hscope + | some (.rLess, e), _, hscope => simp [Cst.VariableDef.toPRScope?] at hscope + | some (.rLessEq, e), _, hscope => simp [Cst.VariableDef.toPRScope?] at hscope + | some (.rGreater, e), _, hscope => simp [Cst.VariableDef.toPRScope?] at hscope + | some (.rGreaterEq, e), _, hscope => simp [Cst.VariableDef.toPRScope?] at hscope + | some (.rNotEq, e), _, hscope => simp [Cst.VariableDef.toPRScope?] at hscope + +/-- Forward leaf translation for the action scope variable. -/ +theorem action_leaf_isSome {va : Cst.VariableDef} {as : ActionScope} + (has : va.toActionScope? = some as) : + ∃ leaf, va.toExpr.toAExpr? = some leaf := by + obtain ⟨var, et, ineq⟩ := va + simp only [Cst.VariableDef.toExpr, Cst.VariableDef.toAndExpr] + cases var + case idAction => + have hv : (Cst.Ident.idAction.varToAddExpr).toExprOrSpecial? = some (Cst.ExprOrSpecial.var .action) := by + simp [Cst.Ident.varToAddExpr, Cst.Primary.toMember, Cst.Member.toUnary, Cst.Unary.toMultExpr, + Cst.MultExpr.toAddExpr, Cst.AddExpr.toExprOrSpecial?, Cst.MultExpr.toExprOrSpecial?, + Cst.Unary.toExprOrSpecial?, Cst.Member.toExprOrSpecial?, Cst.Primary.toExprOrSpecial?, + Cst.Name.toVar?, Cst.memberAuxA, Cst.memberAux] + have hv2 : (Cst.Ident.idAction.varToAddExpr).toAExpr? = some (Expr.var .action) := by + simp [Cst.AddExpr.toAExpr?, hv, Cst.ExprOrSpecial.toExpr?] + cases et + case some t => + simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?] at has + case none => + cases ineq with + | none => + rw [andExpr_single_collapse] + simp [Cst.Relation.tt, Cst.Primary.toMember, Cst.Member.toUnary, Cst.Unary.toMultExpr, + Cst.MultExpr.toAddExpr, Cst.AddExpr.toRelation, Cst.Relation.toAExpr?, + Cst.Relation.toExprOrSpecial?, Cst.AddExpr.toExprOrSpecial?, Cst.MultExpr.toExprOrSpecial?, + Cst.Unary.toExprOrSpecial?, Cst.Member.toExprOrSpecial?, Cst.Primary.toExprOrSpecial?, + Cst.Literal.toExprOrSpecial?, Cst.memberAuxA, Cst.memberAux, Cst.ExprOrSpecial.toExpr?] + | some opE => + obtain ⟨op, e⟩ := opE + cases op with + | rEq => + cases huid : e.toEntityUID? with + | none => simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?, huid] at has + | some uid => + rw [andExpr_single_collapse] + simp [Cst.Relation.toAExpr?, Cst.Relation.toExprOrSpecial?, hv, Cst.constructExprRel, + toAddExpr_toAExpr, toEntityUID_toAExpr huid, Cst.ExprOrSpecial.toExpr?] + | rIn => + cases hr : e.toMultipleEntityUID? with + | none => simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?, + Cst.Expr.toEntityUIDs?, hr] at has + | some r => + have hmem := expr_mem_toAExpr hr + rw [andExpr_single_collapse] + simp [Cst.Relation.toAExpr?, Cst.Relation.toExprOrSpecial?, hv, Cst.constructExprRel, + toAddExpr_toAExpr, hmem, Cst.ExprOrSpecial.toExpr?] + | rLess => simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?] at has + | rLessEq => simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?] at has + | rGreater => simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?] at has + | rGreaterEq => simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?] at has + | rNotEq => simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?] at has + all_goals simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?] at has + +/-- Forward leaf translation for a condition. -/ +theorem cond_leaf_isSome {c : Cst.Cond} {cond : Condition} + (hcond : c.toCondition? = some cond) : + ∃ leaf, (Cst.Cond.toExpr c).toAExpr? = some leaf := by + obtain ⟨ccond, cbody⟩ := c + cases ccond <;> + simp_all [Cst.Cond.toCondition?, Cst.Ident.toConditionKind?, Cst.Cond.toExpr, + Option.bind_eq_some_iff] + case idWhen => + obtain ⟨body, hbody, _⟩ := hcond + exact ⟨body, hbody⟩ + case idUnless => + obtain ⟨body, hbody, _⟩ := hcond + exact ⟨_, cond_not_toAExpr hbody⟩ + +/-- Principal-scope variable translates. -/ +theorem principal_leaf_isSome {vp : Cst.VariableDef} {ps : PrincipalScope} + (hps : vp.toPrincipalScope? = some ps) : + ∃ leaf, vp.toExpr.toAExpr? = some leaf := by + simp only [Cst.VariableDef.toPrincipalScope?] at hps + split at hps <;> [skip; simp at hps] + rename_i hvar + simp [Option.bind_eq_some_iff] at hps + obtain ⟨scope, hscope, _⟩ := hps + have hv : (vp.var.varToAddExpr).toExprOrSpecial? = some (Cst.ExprOrSpecial.var .principal) := by + rw [hvar]; simp [Cst.Ident.varToAddExpr, Cst.Primary.toMember, Cst.Member.toUnary, + Cst.Unary.toMultExpr, Cst.MultExpr.toAddExpr, Cst.AddExpr.toExprOrSpecial?, + Cst.MultExpr.toExprOrSpecial?, Cst.Unary.toExprOrSpecial?, Cst.Member.toExprOrSpecial?, + Cst.Primary.toExprOrSpecial?, Cst.Name.toVar?, Cst.memberAuxA, Cst.memberAux] + exact toPRScope_leaf_isSome hv hscope + +/-- Resource-scope variable translates. -/ +theorem resource_leaf_isSome {vr : Cst.VariableDef} {rs : ResourceScope} + (hrs : vr.toResourceScope? = some rs) : + ∃ leaf, vr.toExpr.toAExpr? = some leaf := by + simp only [Cst.VariableDef.toResourceScope?] at hrs + split at hrs <;> [skip; simp at hrs] + rename_i hvar + simp [Option.bind_eq_some_iff] at hrs + obtain ⟨scope, hscope, _⟩ := hrs + have hv : (vr.var.varToAddExpr).toExprOrSpecial? = some (Cst.ExprOrSpecial.var .resource) := by + rw [hvar]; simp [Cst.Ident.varToAddExpr, Cst.Primary.toMember, Cst.Member.toUnary, + Cst.Unary.toMultExpr, Cst.MultExpr.toAddExpr, Cst.AddExpr.toExprOrSpecial?, + Cst.MultExpr.toExprOrSpecial?, Cst.Unary.toExprOrSpecial?, Cst.Member.toExprOrSpecial?, + Cst.Primary.toExprOrSpecial?, Cst.Name.toVar?, Cst.memberAuxA, Cst.memberAux] + exact toPRScope_leaf_isSome hv hscope + +/-- All condition leaves translate when `toConditions?` succeeds. -/ +theorem conds_mapM_toAExpr_isSome {conds : List Cst.Cond} {acconds : Conditions} + (h : conds.mapM (·.toCondition?) = some acconds) : + ∃ r, (conds.map Cst.Cond.toExpr).mapM Cst.Expr.toAExpr? = some r := by + induction conds generalizing acconds with + | nil => exact ⟨[], by simp⟩ + | cons hd tl ih => + simp [List.mapM_cons, Option.bind_eq_some_iff] at h + obtain ⟨c0, hc0, crest, hcrest, _⟩ := h + obtain ⟨leaf, hleaf⟩ := cond_leaf_isSome hc0 + obtain ⟨r, hr⟩ := ih hcrest + refine ⟨leaf :: r, ?_⟩ + rw [List.map_cons, List.mapM_cons] + simp [hleaf, hr] + +/- Helpers for the policy-list translation soundness proof -/ + +/-- `toPolicy?` produces a policy whose `id` field is the CST policy's `id`. -/ +theorem toPolicy?_id_eq {cp : Cst.Policy} {ap : Spec.Policy} : + cp.toPolicy? = some ap → ap.id = cp.id := by + intro h + obtain ⟨p⟩ := cp + simp only [Cst.Policy.toPolicy?, Cst.PolicyImpl.toPolicy?, bind, Option.bind_eq_some_iff, + Option.some.injEq] at h + obtain ⟨eff, heff, ⟨ps, acts, rs⟩, hsc, conds, hconds, heq⟩ := h + simp only [← heq, Cst.Policy.id] + +/-- `filterMap` congruence across two lists related pointwise. -/ +theorem filterMap_congr_forall₂ {α β γ : Type} {f : α → Option γ} {g : β → Option γ} + {R : α → β → Prop} {xs : List α} {ys : List β} : + List.Forall₂ R xs ys → (∀ a b, R a b → f a = g b) → + xs.filterMap f = ys.filterMap g := by + intro h hfg + induction h with + | nil => rfl + | cons hhd htl ih => + rename_i a b xs' ys' + simp only [List.filterMap, hfg _ _ hhd, ih] + +/-- `Cst.Policies.toPolicies?` relates the original CST policies to the translated + AST policies pointwise: each CST policy translates (via `toPolicy?`) to the + corresponding AST policy. The id is carried through by `toPolicy?` itself (see + `toPolicy?_id_eq`). -/ +theorem toPolicies?_forall₂ {cps : Cst.Policies} {aps : Spec.Policies} : + cps.toPolicies? = some aps → + List.Forall₂ (fun (cp : Cst.Policy) (ap : Spec.Policy) => cp.toPolicy? = some ap) + cps.ps aps := by + simp only [Cst.Policies.toPolicies?] + generalize cps.ps = ps + induction ps generalizing aps with + | nil => + intro htrans + simp only [List.mapM_nil, Option.pure_def, Option.some.injEq] at htrans + subst htrans + exact List.Forall₂.nil + | cons hd tl ih => + intro htrans + simp [List.mapM_cons, Option.bind_eq_some_iff] at htrans + obtain ⟨a0, ha0, restRets, hrest, hretseq⟩ := htrans + subst hretseq + exact List.Forall₂.cons ha0 (ih hrest) diff --git a/cedar-lean/Cedar/Thm/Frontend/Translation/ExprComplete.lean b/cedar-lean/Cedar/Thm/Frontend/Translation/ExprComplete.lean new file mode 100644 index 000000000..cf9a7daf6 --- /dev/null +++ b/cedar-lean/Cedar/Thm/Frontend/Translation/ExprComplete.lean @@ -0,0 +1,627 @@ +import Cedar.Spec +import Cedar.Frontend.Cst +import Cedar.Frontend.Cst.Semantics +import Cedar.Frontend.Cst.ToAst + +import Cedar.Thm.Data.List.Lemmas +import Cedar.Thm.Frontend.Translation.AuxSound +import Cedar.Thm.Frontend.Translation.AuxComplete +import Cedar.Thm.Frontend.Translation.ExprTranslation + +/-! +Translation completeness for CST expressions: if a CST expression evaluates +without error, its translation to AST succeeds. + +The full mutual family (`Primary`, `Member`, `Unary`, …, down to `Expr`) is +proven below by mutual well-founded recursion on the CST size. +-/ + +namespace Cedar.Thm + +open Cedar.Data +open Cedar.Spec +open Cedar.Frontend + +mutual + +theorem Cst.Primary.toAExpr?_complete + {prim : Cst.Primary} {req : Request} {es : Entities} {v : Value} : + prim.evaluate req es = .ok v → + ∃ eos ae, prim.toExprOrSpecial? = some eos ∧ eos.toExpr? = some ae := by + intro hev + cases prim with + | literal lit => + cases lit with + | liTrue => + exact ⟨.boolLit true, .lit (.bool true), + by simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?], + by simp [Cst.ExprOrSpecial.toExpr?]⟩ + | liFalse => + exact ⟨.boolLit false, .lit (.bool false), + by simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?], + by simp [Cst.ExprOrSpecial.toExpr?]⟩ + | liNum n => + simp only [Cst.Primary.evaluate] at hev + cases hn : Int64.ofInt? (n.toNat : Int) with + | none => rw [hn] at hev; simp at hev + | some i => + refine ⟨.expr (.lit (.int i)), .lit (.int i), ?_, by simp [Cst.ExprOrSpecial.toExpr?]⟩ + simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?, hn] + | liStr s => + simp only [Cst.Primary.evaluate, Cst.Str.toUnescapedString] at hev + cases hs : Cst.unescape? s with + | none => rw [hs] at hev; simp at hev + | some s' => + refine ⟨.strLit s, .lit (.string s'), + by simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?], ?_⟩ + simp [Cst.ExprOrSpecial.toExpr?, hs] + | name n => + cases hvar : n.toVar? with + | some var => + exact ⟨.var var, .var var, by simp [Cst.Primary.toExprOrSpecial?, hvar], + by simp [Cst.ExprOrSpecial.toExpr?]⟩ + | none => + exfalso + obtain ⟨npath, nname⟩ := n + simp only [Cst.Name.toVar?] at hvar + cases npath <;> cases nname <;> + simp_all [Cst.Primary.evaluate] + | ref r => + cases r with + | uid path eid => + let (.string s) := eid + simp only [Cst.Primary.evaluate, Cst.Str.toUnescapedString] at hev + cases hs : Cst.unescape? s with + | none => rw [hs] at hev; simp [bind, Except.bind] at hev + | some s' => + rw [hs] at hev + cases hty : Cst.Name.toAName? path with + | none => simp [hty, bind, Except.bind] at hev + | some ty => + refine ⟨.expr (.lit (.entityUID { ty := ty, eid := s' })), + .lit (.entityUID { ty := ty, eid := s' }), ?_, by simp [Cst.ExprOrSpecial.toExpr?]⟩ + simp [Cst.Primary.toExprOrSpecial?, Cst.Ref.toExprOrSpecial?, hty, hs] + | ref path rinits => + simp [Cst.Primary.evaluate] at hev + | expr e => + simp only [Cst.Primary.evaluate] at hev + obtain ⟨eos_e, ae, heos_e, hae⟩ := Cst.Expr.toAExpr?_complete hev + refine ⟨.expr ae, ae, ?_, by simp [Cst.ExprOrSpecial.toExpr?]⟩ + simp [Cst.Primary.toExprOrSpecial?, Cst.Expr.toAExpr?, heos_e, hae] + | eList xs => + simp only [Cst.Primary.evaluate, bind, Except.bind] at hev + cases hxs : xs.mapM (fun x => x.evaluate req es) with + | error e => rw [hxs] at hev; simp at hev + | ok vs => + obtain ⟨aes, haes⟩ := list_eval_complete xs vs hxs + (fun x _hx _v hxv => by + obtain ⟨eos, ae, heos, hae⟩ := Cst.Expr.toAExpr?_complete hxv + exact ⟨ae, by simp [Cst.Expr.toAExpr?, heos, hae]⟩) + refine ⟨.expr (.set aes), .set aes, ?_, by simp [Cst.ExprOrSpecial.toExpr?]⟩ + simp [Cst.Primary.toExprOrSpecial?, List.mapM₁_eq_mapM (fun x : Cst.Expr => x.toAExpr?), haes] + | rInits r => + have hCST : (Cst.Primary.rInits r).evaluate req es = + (r.mapM (fun ri => + match ri.attr.toAttr? with + | none => Except.error (Error.cstError CstError.stringError) + | some attr => do let val ← ri.value.evaluate req es; Except.ok (attr, val))) >>= + fun avs => Except.ok (Value.record (Map.make avs)) := by + simp only [Cst.Primary.evaluate] + congr 1 + exact List.mapM₁_eq_mapM (fun ri : Cst.RecInit => + match ri.attr.toAttr? with + | none => Except.error (Error.cstError CstError.stringError) + | some attr => do let val ← ri.value.evaluate req es; Except.ok (attr, val)) r + rw [hCST] at hev + cases hrv : r.mapM (fun ri => + match ri.attr.toAttr? with + | none => Except.error (Error.cstError CstError.stringError) + | some attr => do let val ← ri.value.evaluate req es; Except.ok (attr, val)) with + | error e => rw [hrv] at hev; simp [bind, Except.bind] at hev + | ok avs => + obtain ⟨map, hmap⟩ := rInits_complete r avs hrv + (fun ri _hri _v hv => by + obtain ⟨eos, ae, heos, hae⟩ := Cst.Expr.toAExpr?_complete hv + exact ⟨ae, by simp [Cst.Expr.toAExpr?, heos, hae]⟩) + refine ⟨.expr (.record map), .record map, ?_, by simp [Cst.ExprOrSpecial.toExpr?]⟩ + simp [Cst.Primary.toExprOrSpecial?, hmap] + | slot _ => + simp [Cst.Primary.evaluate] at hev +termination_by (sizeOf prim, 0) +decreasing_by + all_goals simp_wf + all_goals first + | (apply Prod.Lex.left + subst_vars + simp only [Cst.Primary.expr.sizeOf_spec] + omega) + | (apply Prod.Lex.left + subst_vars + simp only [Cst.Primary.eList.sizeOf_spec] + have := List.sizeOf_lt_of_mem (show x ∈ xs by assumption) + omega) + | (apply Prod.Lex.left + subst_vars + simp only [Cst.Primary.rInits.sizeOf_spec] + have := List.sizeOf_lt_of_mem (show ri ∈ r by assumption) + cases ri + simp only [Cst.RecInit.mk.sizeOf_spec] at * + omega) + +theorem Cst.Member.toAExpr?_complete + {mem : Cst.Member} {req : Request} {es : Entities} {v : Value} : + mem.evaluate req es = .ok v → + ∃ eos ae, mem.toExprOrSpecial? = some eos ∧ eos.toExpr? = some ae := by + intro hev + have harg : ∀ ce : Cst.Expr, sizeOf ce < sizeOf mem.access → + ∀ w, ce.evaluate req es = .ok w → ∃ ax, ce.toAExpr? = some ax := by + intro ce _hsz w hcw + obtain ⟨eos', ae', heos', hae'⟩ := Cst.Expr.toAExpr?_complete hcw + exact ⟨ae', by simp [Cst.Expr.toAExpr?, heos', hae']⟩ + unfold Cst.Member.evaluate at hev + split at hev + case h_1 s _ args rest => + cases hfn : Cst.String.toExtFun? s with + | none => rw [hfn] at hev; simp at hev + | some xfn => + rw [hfn] at hev + cases hargs : args.mapM (fun a => a.evaluate req es) with + | error e => rw [hargs] at hev; simp [bind, Except.bind] at hev + | ok argVals => + rw [hargs] at hev; simp only [bind, Except.bind] at hev + cases hcall : call xfn argVals with + | error e => rw [hcall] at hev; simp at hev + | ok callVal => + rw [hcall] at hev + obtain ⟨xs, hxs⟩ := list_eval_complete args argVals hargs + (fun ce hce w hcw => harg ce (by + show sizeOf ce < sizeOf (Cst.MemAccess.call args :: rest) + have := List.sizeOf_lt_of_mem hce + simp only [List.cons.sizeOf_spec, Cst.MemAccess.call.sizeOf_spec]; omega) w hcw) + obtain ⟨rest_ast, hrest, _, hmemb⟩ := evalAccessors_complete rest callVal v hev + (fun ce hsz w hcw => harg ce (by + show sizeOf ce < sizeOf (Cst.MemAccess.call args :: rest) + simp only [List.cons.sizeOf_spec, Cst.MemAccess.call.sizeOf_spec] at hsz ⊢; omega) + w hcw) + obtain ⟨r, hr⟩ := hmemb (.call xfn xs) + refine ⟨.expr r, r, ?_, by simp [Cst.ExprOrSpecial.toExpr?]⟩ + simp [Cst.Member.toExprOrSpecial?, Cst.Primary.toExprOrSpecial?, + Cst.Name.toVar?, List.isEmpty_nil, Cst.Name.toAName?, Cst.Name.toAName?, + Cst.Ident.toUnrestrictedString?, List.mapM_cons, Cst.MemAccess.toAstAccessor?, + toAExprs?_eq_mapM, hxs, hrest, Cst.memberAux, Cst.memberAuxA, Cst.toFunc?, + toExtFun?_some_isFunctionName hfn, hfn, hr] + case h_2 item access hnfc => + simp only [bind, Except.bind] at hev + cases hitem : item.evaluate req es with + | error e => rw [hitem] at hev; simp at hev + | ok head => + rw [hitem] at hev; simp only at hev + obtain ⟨peos, headExpr, hpeos, hpe⟩ := Cst.Primary.toAExpr?_complete hitem + obtain ⟨accs_ast, haccs, _, hmemb⟩ := evalAccessors_complete access head v hev harg + obtain ⟨r, hr⟩ := hmemb headExpr + have hbind : (Cst.memberAux peos accs_ast).bind Cst.ExprOrSpecial.toExpr? = some r := by + rw [memberAux_toExpr_eq accs_ast hpe]; exact hr + rw [Option.bind_eq_some_iff] at hbind + obtain ⟨eos, hmaux, heos⟩ := hbind + refine ⟨eos, r, ?_, heos⟩ + simp only [Cst.Member.toExprOrSpecial?, hpeos, haccs, hmaux, Option.bind_some, + Option.bind_eq_bind] +termination_by (sizeOf mem, 0) +decreasing_by + all_goals + (apply Prod.Lex.left + first + | (subst_vars; simp only [Cst.Member.mk.sizeOf_spec]; omega) + | (cases mem; simp only [Cst.Member.mk.sizeOf_spec] at *; omega)) + +theorem Cst.Unary.toAExpr?_complete + {u : Cst.Unary} {req : Request} {es : Entities} {v : Value} : + u.evaluate req es = .ok v → + ∃ eos ae, u.toExprOrSpecial? = some eos ∧ eos.toExpr? = some ae := by + intro hev + match hop : u.op with + | none => + simp only [Cst.Unary.evaluate, hop] at hev + obtain ⟨eos, ae, heos, hae⟩ := Cst.Member.toAExpr?_complete hev + exact ⟨eos, ae, by simp [Cst.Unary.toExprOrSpecial?, hop, heos], hae⟩ + | some (.nBang n) => + simp only [Cst.Unary.evaluate, hop] at hev + cases hitem : u.item.evaluate req es with + | error e => simp [hitem, bind, Except.bind] at hev + | ok mval => + obtain ⟨ieos, iexpr, hieos, hiexpr⟩ := Cst.Member.toAExpr?_complete hitem + exact ⟨.expr (Cst.bangN iexpr n.toNat), Cst.bangN iexpr n.toNat, + by simp [Cst.Unary.toExprOrSpecial?, hop, hieos, hiexpr], + by simp [Cst.ExprOrSpecial.toExpr?]⟩ + | some (.nDash n) => + by_cases hn0 : n = 0 + · subst hn0 + simp only [Cst.Unary.evaluate, hop] at hev + simp only [beq_self_eq_true, if_true] at hev + obtain ⟨eos, ae, heos, hae⟩ := Cst.Member.toAExpr?_complete hev + exact ⟨eos, ae, by simp [Cst.Unary.toExprOrSpecial?, hop, heos], hae⟩ + · simp only [Cst.Unary.evaluate, hop] at hev + rw [if_neg (by simp [hn0])] at hev + cases hlit : Cst.Member.toLit? u.item with + | none => + simp only [hlit] at hev + cases hitem : u.item.evaluate req es with + | error e => rw [hitem] at hev; simp [bind, Except.bind] at hev + | ok mval => + obtain ⟨ieos, iexpr, hieos, hiexpr⟩ := Cst.Member.toAExpr?_complete hitem + exact ⟨.expr (Cst.dashN iexpr n.toNat), Cst.dashN iexpr n.toNat, + by simp [Cst.Unary.toExprOrSpecial?, hop, hlit, hieos, hiexpr], + by simp [Cst.ExprOrSpecial.toExpr?]⟩ + | some lit => + cases lit with + | liNum x => + simp only [hlit] at hev + cases hcmp : compare x.toNat (Int64.MAX + 1).toNat with + | gt => rw [hcmp] at hev; simp at hev + | eq => + exact ⟨.expr (Cst.dashN (Expr.lit (.int Int64.MIN.toInt64)) (n-1).toNat), + Cst.dashN (Expr.lit (.int Int64.MIN.toInt64)) (n-1).toNat, + by simp [Cst.Unary.toExprOrSpecial?, hop, hlit, hcmp], + by simp [Cst.ExprOrSpecial.toExpr?]⟩ + | lt => + simp only [hcmp] at hev + cases hof : Int64.ofInt? (x.toNat : Int) with + | none => simp [hof] at hev + | some y => + exact ⟨.expr (Cst.dashN (Expr.lit (.int (-y))) (n-1).toNat), + Cst.dashN (Expr.lit (.int (-y))) (n-1).toNat, + by simp [Cst.Unary.toExprOrSpecial?, hop, hlit, hcmp, hof], + by simp [Cst.ExprOrSpecial.toExpr?]⟩ + | liTrue => + simp only [hlit] at hev + cases hitem : u.item.evaluate req es with + | error e => rw [hitem] at hev; simp [bind, Except.bind] at hev + | ok mval => + obtain ⟨ieos, iexpr, hieos, hiexpr⟩ := Cst.Member.toAExpr?_complete hitem + exact ⟨.expr (Cst.dashN iexpr n.toNat), Cst.dashN iexpr n.toNat, + by simp [Cst.Unary.toExprOrSpecial?, hop, hlit, hieos, hiexpr], + by simp [Cst.ExprOrSpecial.toExpr?]⟩ + | liFalse => + simp only [hlit] at hev + cases hitem : u.item.evaluate req es with + | error e => rw [hitem] at hev; simp [bind, Except.bind] at hev + | ok mval => + obtain ⟨ieos, iexpr, hieos, hiexpr⟩ := Cst.Member.toAExpr?_complete hitem + exact ⟨.expr (Cst.dashN iexpr n.toNat), Cst.dashN iexpr n.toNat, + by simp [Cst.Unary.toExprOrSpecial?, hop, hlit, hieos, hiexpr], + by simp [Cst.ExprOrSpecial.toExpr?]⟩ + | liStr s => + simp only [hlit] at hev + cases hitem : u.item.evaluate req es with + | error e => rw [hitem] at hev; simp [bind, Except.bind] at hev + | ok mval => + obtain ⟨ieos, iexpr, hieos, hiexpr⟩ := Cst.Member.toAExpr?_complete hitem + exact ⟨.expr (Cst.dashN iexpr n.toNat), Cst.dashN iexpr n.toNat, + by simp [Cst.Unary.toExprOrSpecial?, hop, hlit, hieos, hiexpr], + by simp [Cst.ExprOrSpecial.toExpr?]⟩ +termination_by (sizeOf u, 0) +decreasing_by + all_goals + (apply Prod.Lex.left + cases u; simp only [Cst.Unary.mk.sizeOf_spec]; omega) + +theorem Cst.MultExpr.toAExpr?_complete + {mult : Cst.MultExpr} {req : Request} {es : Entities} {v : Value} : + mult.evaluate req es = .ok v → + ∃ eos ae, mult.toExprOrSpecial? = some eos ∧ eos.toExpr? = some ae := by + intro hev + simp only [Cst.MultExpr.evaluate] at hev + cases hinit : mult.initial.evaluate req es with + | error e => rw [hinit] at hev; simp [bind, Except.bind] at hev + | ok b => + rw [hinit] at hev + simp only [bind, Except.bind] at hev + match hext : mult.extended with + | [] => + obtain ⟨eos, ae, heos, hae⟩ := Cst.Unary.toAExpr?_complete hinit + exact ⟨eos, ae, by simp [Cst.MultExpr.toExprOrSpecial?, hext, heos], hae⟩ + | hd :: tl => + obtain ⟨ieos, iexpr, hieos, hiexpr⟩ := Cst.Unary.toAExpr?_complete hinit + have hinitA : mult.initial.toAExpr? = some iexpr := by + simp [Cst.Unary.toAExpr?, hieos, hiexpr] + obtain ⟨result, hresult⟩ := + multExprFoldExtended_complete mult.extended b iexpr v hev + (fun u' _hsz w hw => by + obtain ⟨eos', ae', heos', hae'⟩ := Cst.Unary.toAExpr?_complete hw + exact ⟨ae', by simp [Cst.Unary.toAExpr?, heos', hae']⟩) + refine ⟨.expr result, result, ?_, by simp [Cst.ExprOrSpecial.toExpr?]⟩ + simp only [hext] at hresult + simp [Cst.MultExpr.toExprOrSpecial?, hext, hinitA, hresult] +termination_by (sizeOf mult, 0) +decreasing_by + all_goals + (apply Prod.Lex.left + have h1 : sizeOf mult.initial < sizeOf mult := by + cases mult; simp only [Cst.MultExpr.mk.sizeOf_spec]; omega + have h2 : sizeOf mult.extended < sizeOf mult := by + cases mult; simp only [Cst.MultExpr.mk.sizeOf_spec]; omega + omega) + +theorem Cst.AddExpr.toAExpr?_complete + {add : Cst.AddExpr} {req : Request} {es : Entities} {v : Value} : + add.evaluate req es = .ok v → + ∃ eos ae, add.toExprOrSpecial? = some eos ∧ eos.toExpr? = some ae := by + intro hev + simp only [Cst.AddExpr.evaluate] at hev + cases hinit : add.initial.evaluate req es with + | error e => rw [hinit] at hev; simp [bind, Except.bind] at hev + | ok b => + rw [hinit] at hev + simp only [bind, Except.bind] at hev + match hext : add.extended with + | [] => + obtain ⟨eos, ae, heos, hae⟩ := Cst.MultExpr.toAExpr?_complete hinit + exact ⟨eos, ae, by simp [Cst.AddExpr.toExprOrSpecial?, hext, heos], hae⟩ + | hd :: tl => + obtain ⟨ieos, iexpr, hieos, hiexpr⟩ := Cst.MultExpr.toAExpr?_complete hinit + have hinitA : add.initial.toAExpr? = some iexpr := by + simp [Cst.MultExpr.toAExpr?, hieos, hiexpr] + obtain ⟨result, hresult⟩ := + addExprFoldExtended_complete add.extended b iexpr v hev + (fun m' _hsz w hw => by + obtain ⟨eos', ae', heos', hae'⟩ := Cst.MultExpr.toAExpr?_complete hw + exact ⟨ae', by simp [Cst.MultExpr.toAExpr?, heos', hae']⟩) + refine ⟨.expr result, result, ?_, by simp [Cst.ExprOrSpecial.toExpr?]⟩ + simp only [hext] at hresult + simp [Cst.AddExpr.toExprOrSpecial?, hext, hinitA, hresult] +termination_by (sizeOf add, 0) +decreasing_by + all_goals + (apply Prod.Lex.left + have h1 : sizeOf add.initial < sizeOf add := by + cases add; simp only [Cst.AddExpr.mk.sizeOf_spec]; omega + have h2 : sizeOf add.extended < sizeOf add := by + cases add; simp only [Cst.AddExpr.mk.sizeOf_spec]; omega + omega) + +theorem Cst.Relation.toAExpr?_complete + {rel : Cst.Relation} {req : Request} {es : Entities} {v : Value} : + rel.evaluate req es = .ok v → + ∃ eos ae, rel.toExprOrSpecial? = some eos ∧ eos.toExpr? = some ae := by + intro hev + cases rel with + | rCommon initial extended => + match hext : extended with + | [] => + simp only [Cst.Relation.evaluate] at hev + obtain ⟨eos, ae, heos, hae⟩ := Cst.AddExpr.toAExpr?_complete hev + exact ⟨eos, ae, by simp [Cst.Relation.toExprOrSpecial?, heos], hae⟩ + | (op, y) :: rest => + match hrest : rest with + | _ :: _ => simp [Cst.Relation.evaluate] at hev + | [] => + simp only [Cst.Relation.evaluate] at hev + cases hi : initial.evaluate req es with + | error e => rw [hi] at hev; simp [bind, Except.bind] at hev + | ok v₁ => + rw [hi] at hev + cases hy : y.evaluate req es with + | error e => rw [hy] at hev; simp [bind, Except.bind] at hev + | ok v₂ => + obtain ⟨ieos, iexpr, hieos, hiexpr⟩ := Cst.AddExpr.toAExpr?_complete hi + obtain ⟨yeos, yexpr, hyeos, hyexpr⟩ := Cst.AddExpr.toAExpr?_complete hy + have hyA : y.toAExpr? = some yexpr := by simp [Cst.AddExpr.toAExpr?, hyeos, hyexpr] + refine ⟨.expr (Cst.constructExprRel op iexpr yexpr), Cst.constructExprRel op iexpr yexpr, + ?_, by simp [Cst.ExprOrSpecial.toExpr?]⟩ + simp [Cst.Relation.toExprOrSpecial?, hieos, hiexpr, hyA] + | rHas target field => + simp only [Cst.Relation.evaluate] at hev + cases htgt : target.evaluate req es with + | error e => rw [htgt] at hev; simp [bind, Except.bind] at hev + | ok vt => + cases hattrs : field.toAttrs? with + | none => rw [htgt, hattrs] at hev; simp [bind, Except.bind] at hev + | some attrs => + obtain ⟨rhs, hrhs⟩ := addExpr_toAttrs_toHasRhs hattrs + obtain ⟨teos, texpr, hteos, htexpr⟩ := Cst.AddExpr.toAExpr?_complete htgt + have htgtA : target.toAExpr? = some texpr := by simp [Cst.AddExpr.toAExpr?, hteos, htexpr] + cases rhs with + | inl fld => + exact ⟨.expr (.hasAttr texpr fld), .hasAttr texpr fld, + by simp [Cst.Relation.toExprOrSpecial?, htgtA, hrhs], by simp [Cst.ExprOrSpecial.toExpr?]⟩ + | inr fs => + exact ⟨.expr (Cst.extendedHasAttr texpr fs), Cst.extendedHasAttr texpr fs, + by simp [Cst.Relation.toExprOrSpecial?, htgtA, hrhs], by simp [Cst.ExprOrSpecial.toExpr?]⟩ + | rLike target pattern => + simp only [Cst.Relation.evaluate] at hev + cases hps : pattern.toPatternString? with + | none => rw [hps] at hev; simp at hev + | some s => + rw [hps] at hev + cases htgt : target.evaluate req es with + | error e => rw [htgt] at hev; simp [bind, Except.bind] at hev + | ok vt => + rw [htgt] at hev + simp only [bind, Except.bind] at hev + cases hcp : Cst.toPattern? s with + | none => rw [hcp] at hev; simp at hev + | some mp => + obtain ⟨teos, texpr, hteos, htexpr⟩ := Cst.AddExpr.toAExpr?_complete htgt + have htgtA : target.toAExpr? = some texpr := by simp [Cst.AddExpr.toAExpr?, hteos, htexpr] + have hpatT : pattern.toPattern? = some mp := by + simp [Cst.AddExpr.toPattern?, addExpr_toPatternString_toExprOrSpecial hps, hcp] + exact ⟨.expr (.unaryApp (.like mp) texpr), .unaryApp (.like mp) texpr, + by simp [Cst.Relation.toExprOrSpecial?, htgtA, hpatT], by simp [Cst.ExprOrSpecial.toExpr?]⟩ + | rIsIn target ety inEntity => + simp only [Cst.Relation.evaluate] at hev + cases hety : ety.toEntityType? with + | none => rw [hety] at hev; simp at hev + | some etyName => + rw [hety] at hev + cases htgt : target.evaluate req es with + | error e => rw [htgt] at hev; simp [bind, Except.bind] at hev + | ok vt => + rw [htgt] at hev + simp only [bind, Except.bind] at hev + obtain ⟨teos, texpr, hteos, htexpr⟩ := Cst.AddExpr.toAExpr?_complete htgt + have htgtA : target.toAExpr? = some texpr := by simp [Cst.AddExpr.toAExpr?, hteos, htexpr] + cases hap : apply₁ (.is etyName) vt with + | error e => rw [hap] at hev; simp at hev + | ok isResult => + rw [hap] at hev + match hinE : inEntity with + | none => + exact ⟨.expr (.unaryApp (.is etyName) texpr), .unaryApp (.is etyName) texpr, + by simp [Cst.Relation.toExprOrSpecial?, htgtA, hety], + by simp [Cst.ExprOrSpecial.toExpr?]⟩ + | some ie => + cases hie : ie.toAExpr? with + | none => simp [hie] at hev + | some mi => + exact ⟨.expr (.and (.unaryApp (.is etyName) texpr) (.binaryApp .mem texpr mi)), + .and (.unaryApp (.is etyName) texpr) (.binaryApp .mem texpr mi), + by simp [Cst.Relation.toExprOrSpecial?, htgtA, hety, hie], + by simp [Cst.ExprOrSpecial.toExpr?]⟩ +termination_by (sizeOf rel, 0) +decreasing_by + all_goals (apply Prod.Lex.left; decreasing_tactic) + +theorem Cst.AndExpr.toAExpr?_complete + {ae : Cst.AndExpr} {req : Request} {es : Entities} {v : Value} : + ae.evaluate req es = .ok v → + ∃ eos aexpr, ae.toExprOrSpecial? = some eos ∧ eos.toExpr? = some aexpr := by + intro hev + by_cases hall : (ae.extended.all fun r => r.toAExpr?.isSome) = true + · rw [AndExpr.evaluate_eq hall] at hev + cases hinit : ae.initial.evaluate req es with + | error e => rw [hinit] at hev; simp [bind, Except.bind] at hev + | ok acc => + obtain ⟨ieos, iexpr, hieos, hiexpr⟩ := Cst.Relation.toAExpr?_complete hinit + match hext : ae.extended with + | [] => + exact ⟨ieos, iexpr, by simp [Cst.AndExpr.toExprOrSpecial?, hext, hieos], hiexpr⟩ + | hd :: tl => + have hinitA : ae.initial.toAExpr? = some iexpr := by + simp [Cst.Relation.toAExpr?, hieos, hiexpr] + obtain ⟨result, hresult⟩ := andExprFoldExtended_complete ae.extended hall iexpr + refine ⟨.expr result, result, ?_, by simp [Cst.ExprOrSpecial.toExpr?]⟩ + simp only [hext] at hresult + simp [Cst.AndExpr.toExprOrSpecial?, hext, hinitA, hresult] + · simp [Cst.AndExpr.evaluate, hall] at hev +termination_by (sizeOf ae, 0) +decreasing_by + all_goals + (apply Prod.Lex.left + cases ae + simp only [Cst.AndExpr.mk.sizeOf_spec] + omega) + +theorem Cst.OrExpr.toAExpr?_complete + {oe : Cst.OrExpr} {req : Request} {es : Entities} {v : Value} : + oe.evaluate req es = .ok v → + ∃ eos aexpr, oe.toExprOrSpecial? = some eos ∧ eos.toExpr? = some aexpr := by + intro hev + by_cases hall : (oe.extended.all fun r => r.toAExpr?.isSome) = true + · rw [OrExpr.evaluate_eq hall] at hev + cases hinit : oe.initial.evaluate req es with + | error e => rw [hinit] at hev; simp [bind, Except.bind] at hev + | ok acc => + obtain ⟨ieos, iexpr, hieos, hiexpr⟩ := Cst.AndExpr.toAExpr?_complete hinit + match hext : oe.extended with + | [] => + exact ⟨ieos, iexpr, by simp [Cst.OrExpr.toExprOrSpecial?, hext, hieos], hiexpr⟩ + | hd :: tl => + have hinitA : oe.initial.toAExpr? = some iexpr := by + simp [Cst.AndExpr.toAExpr?, hieos, hiexpr] + obtain ⟨result, hresult⟩ := orExprFoldExtended_complete oe.extended hall iexpr + refine ⟨.expr result, result, ?_, by simp [Cst.ExprOrSpecial.toExpr?]⟩ + simp only [hext] at hresult + simp [Cst.OrExpr.toExprOrSpecial?, hext, hinitA, hresult] + · simp [Cst.OrExpr.evaluate, hall] at hev +termination_by (sizeOf oe, 0) +decreasing_by + all_goals + (apply Prod.Lex.left + cases oe + simp only [Cst.OrExpr.mk.sizeOf_spec] + omega) + +theorem Cst.ExprData.toAExpr?_complete + {ed : Cst.ExprData} {req : Request} {es : Entities} {v : Value} : + ed.evaluate req es = .ok v → + ∃ eos ae, ed.toExprOrSpecial? = some eos ∧ eos.toExpr? = some ae := by + intro hev + cases ed with + | edOr ore => + simp only [Cst.ExprData.evaluate] at hev + obtain ⟨eos, ae, heos, hae⟩ := Cst.OrExpr.toAExpr?_complete hev + exact ⟨eos, ae, by simp [Cst.ExprData.toExprOrSpecial?, heos], hae⟩ + | edIf i t f => + by_cases hguard : (t.toAExpr?.isSome && f.toAExpr?.isSome) = true + · rw [ExprData.evaluate_edIf_eq hguard] at hev + -- `i` is always evaluated, so a successful evaluation forces `i.evaluate` + -- to succeed, and Expr-level completeness recovers `i`'s translation. + cases hi : i.evaluate req es with + | error e => rw [hi] at hev; simp [bind, Except.bind, Result.as] at hev + | ok iv => + obtain ⟨ieos, iexpr, hieos, hiexpr⟩ := Cst.Expr.toAExpr?_complete hi + have hiA : i.toAExpr? = some iexpr := by simp [Cst.Expr.toAExpr?, hieos, hiexpr] + simp only [Bool.and_eq_true] at hguard + obtain ⟨ht, hf⟩ := hguard + cases htt : t.toAExpr? with + | none => rw [htt] at ht; simp at ht + | some texpr => + cases hff : f.toAExpr? with + | none => rw [hff] at hf; simp at hf + | some fexpr => + exact ⟨.expr (.ite iexpr texpr fexpr), .ite iexpr texpr fexpr, + by simp [Cst.ExprData.toExprOrSpecial?, hiA, htt, hff], + by simp [Cst.ExprOrSpecial.toExpr?]⟩ + · simp [Cst.ExprData.evaluate, hguard] at hev +termination_by (sizeOf ed, 0) +decreasing_by + all_goals (apply Prod.Lex.left; decreasing_tactic) + +theorem Cst.ExprImpl.toAExpr?_complete + {ei : Cst.ExprImpl} {req : Request} {es : Entities} {v : Value} : + ei.evaluate req es = .ok v → + ∃ eos ae, ei.toExprOrSpecial? = some eos ∧ eos.toExpr? = some ae := by + intro hev + simp only [Cst.ExprImpl.evaluate] at hev + have hed := Cst.ExprData.toAExpr?_complete hev + obtain ⟨eos, ae, hed1, hed2⟩ := hed + exists eos, ae; constructor + · simp only [Cst.ExprImpl.toExprOrSpecial?]; exact hed1 + · exact hed2 +termination_by (sizeOf ei, 0) +decreasing_by + all_goals + (apply Prod.Lex.left + cases ei; simp only [Cst.ExprImpl.mk.sizeOf_spec]; omega) + +theorem Cst.Expr.toAExpr?_complete + {e : Cst.Expr} {req : Request} {es : Entities} {v : Value} : + e.evaluate req es = .ok v → + ∃ eos ae, e.toExprOrSpecial? = some eos ∧ eos.toExpr? = some ae := by + intro hev + cases e with + | expr e => + simp only [Cst.Expr.evaluate] at hev + have h := (Cst.ExprImpl.toAExpr?_complete hev) + obtain ⟨eos, ae, h1, h2⟩ := h + exists eos, ae; constructor + · simp only [Cst.Expr.toExprOrSpecial?]; exact h1 + · exact h2 +termination_by (sizeOf e, 0) +decreasing_by + all_goals (apply Prod.Lex.left; decreasing_tactic) + +theorem expr_to_expr_complete + {e : Cst.Expr} {req : Request} {es : Entities} {v : Value} : + e.evaluate req es = .ok v → + ∃ ae, e.toAExpr? = some ae := by + intro hev + have h := Cst.Expr.toAExpr?_complete hev + obtain ⟨eos, ae, h1, h2⟩ := h + exists ae + simp only [Cst.Expr.toAExpr?, h1, bind, Option.bind] + exact h2 + +end + +end Cedar.Thm diff --git a/cedar-lean/Cedar/Thm/Frontend/Translation/ExprTranslation.lean b/cedar-lean/Cedar/Thm/Frontend/Translation/ExprTranslation.lean new file mode 100644 index 000000000..e142888ad --- /dev/null +++ b/cedar-lean/Cedar/Thm/Frontend/Translation/ExprTranslation.lean @@ -0,0 +1,968 @@ +import Cedar.Spec +import Cedar.Frontend.Cst +import Cedar.Frontend.Cst.Semantics +import Cedar.Frontend.Cst.ToAst +import Cedar.Thm.Frontend.Translation.AuxSound +import Cedar.Thm.Data.List.Lemmas + +namespace Cedar.Thm + +open Cedar.Data +open Cedar.Spec +open Cedar.Frontend + + +set_option maxHeartbeats 1000000 + +theorem Cst.ExprOrSpecial.toExpr?_sound {eos : Cst.ExprOrSpecial} {aexp : Expr} req es : + eos.toExpr? = some aexp → + evaluate aexp req es = + (match eos with + | .expr e => evaluate e req es + | .var var => evaluate (Expr.var var) req es + | .strLit s => (Cst.unescape? s).elim + (.error (.cstError .stringError)) + (fun s' => .ok (.prim (.string s'))) + | .boolLit b => .ok (.prim (.bool b)) + | .name _ => .error (.cstError .nameError)) := by + cases eos <;> intro h <;> simp_all [Cst.ExprOrSpecial.toExpr?] + · rename_i lit + cases hsome : Cst.unescape? lit with + | none => simp [hsome] at h + | some s' => simp only [hsome] at h ⊢; simp at h; subst h; simp [evaluate] + · rename_i b; subst h; simp [evaluate] + +mutual + +theorem Cst.Primary.toAExpr?_sound + {prim : Cst.Primary} {eos : Cst.ExprOrSpecial} + {req : Request} {es : Entities} : + prim.toExprOrSpecial? = some eos → + ∀ aexp, eos.toExpr? = some aexp → + evaluate aexp req es = prim.evaluate req es := by + cases prim with + | literal lit => + intro hprim aexp heos + rw [Cst.ExprOrSpecial.toExpr?_sound req es heos] + simp [Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?] at hprim + cases lit with + | liTrue | liFalse => + simp at hprim; subst hprim; simp [Cst.Primary.evaluate] + | liNum n => + simp at hprim + cases hn : Int64.ofInt? ↑n.toNat with + | none => rw [hn] at hprim; simp at hprim + | some n' => + rw [hn] at hprim; simp at hprim; subst hprim + simp [Cst.Primary.evaluate, hn, evaluate] + | liStr s => + simp at hprim; subst hprim + simp [Cst.Primary.evaluate, Cst.Str.toUnescapedString] + cases hs : Cst.unescape? s <;> simp + | ref r => + intro href aexp heos + rw [Cst.ExprOrSpecial.toExpr?_sound req es heos] + simp [Cst.Primary.toExprOrSpecial?] at href + cases r with + | uid path eid => + let (.string s) := eid + simp [Cst.Ref.toExprOrSpecial?] at href + simp only [Option.bind_eq_some_iff] at href + obtain ⟨ty, hty, su, hsu1, hsu2⟩ := href + simp at hsu2; subst hsu2 + simp [Cst.Primary.evaluate, Cst.Str.toUnescapedString] + cases hs : Cst.unescape? s with + | none => rw [hs] at hsu1; contradiction + | some su' => + rw [hs] at hsu1; simp at hsu1 + simp [hsu1, bind, Except.bind] + simp [evaluate, hty] + | ref path rinits => simp [Cst.Ref.toExprOrSpecial?] at href + | name n => + intro hname aexp heos + rw [Cst.ExprOrSpecial.toExpr?_sound req es heos] + simp [Cst.Primary.toExprOrSpecial?] at hname + unfold Cst.Primary.evaluate + cases hvar : n.toVar? with + | none => + simp [hvar] at hname + simp only [Option.bind_eq_some_iff] at hname + obtain ⟨name, hname1, hname2⟩ := hname + simp at hname2; subst hname2 + simp [Cst.ExprOrSpecial.toExpr?] at heos + | some var => + simp [hvar] at hname; subst hname + cases hpath : n.path with + | nil => + simp + have ⟨hvn1, hvn2⟩ := Cst.Name.toVar?_agrees hvar + cases hv : var with + | principal => simp [hv] at hvn2; simp [evaluate, hvn2] + | action => simp [hv] at hvn2; simp [evaluate, hvn2] + | resource => simp [hv] at hvn2; simp [evaluate, hvn2] + | context => simp [hv] at hvn2; simp [evaluate, hvn2] + | cons hd tl => + have ⟨hvn1, _⟩ := Cst.Name.toVar?_agrees hvar + simp [hvn1] at hpath + | expr e => + intro hprim aexp heos + simp [Cst.Primary.toExprOrSpecial?, Option.bind_eq_some_iff] at hprim + obtain ⟨ae, hae, heq⟩ := hprim + rw [← heq] at heos + simp [Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + simp [Cst.Primary.evaluate] + simp [Cst.Expr.toAExpr?, Option.bind_eq_some_iff] at hae + obtain ⟨eEos, heEos, heExpr⟩ := hae + exact Cst.Expr.toAExpr?_sound heEos ae heExpr + | eList xs => + intro hprim aexp heos + simp [Cst.Primary.toExprOrSpecial?, Option.bind_eq_some_iff] at hprim + obtain ⟨aes, haes, heq⟩ := hprim + rw [← heq] at heos + simp [Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + have hperElt : ∀ x ∈ xs, ∀ ax, x.toAExpr? = some ax → + evaluate ax req es = x.evaluate req es := by + intro x hx ax hax + have hsz : sizeOf x < sizeOf (Cst.Primary.eList xs) := by + have := List.sizeOf_lt_of_mem hx + simp only [Cst.Primary.eList.sizeOf_spec]; omega + simp [Cst.Expr.toAExpr?, Option.bind_eq_some_iff] at hax + obtain ⟨xEos, hxEos, hxExpr⟩ := hax + exact Cst.Expr.toAExpr?_sound hxEos ax hxExpr + have hbridge := mapM_eval_eq req es xs aes haes hperElt + simp [evaluate, Cst.Primary.evaluate, bind, Except.bind, + List.mapM₁_eq_mapM (evaluate · req es)] + rw [hbridge] + | rInits r => + intro hprim aexp heos + simp [Cst.Primary.toExprOrSpecial?, Option.bind_eq_some_iff] at hprim + obtain ⟨map, hmap, heq⟩ := hprim + rw [← heq] at heos + simp [Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + have hperElt : ∀ ri ∈ r, ∀ ax, ri.value.toAExpr? = some ax → + evaluate ax req es = ri.value.evaluate req es := by + intro ri hmem ax hax + have hsz : sizeOf ri.value < sizeOf (Cst.Primary.rInits r) := by + have h1 := List.sizeOf_lt_of_mem hmem + have hval : sizeOf ri.value < sizeOf ri := by + cases ri; simp only [Cst.RecInit.mk.sizeOf_spec]; omega + simp only [Cst.Primary.rInits.sizeOf_spec]; omega + simp [Cst.Expr.toAExpr?, Option.bind_eq_some_iff] at hax + obtain ⟨vEos, hvEos, hvExpr⟩ := hax + exact Cst.Expr.toAExpr?_sound hvEos ax hvExpr + exact rInits_record_eval_eq req es r map hmap hperElt + | slot _ => + intro hprim + simp [Cst.Primary.toExprOrSpecial?] at hprim + +termination_by (sizeOf prim, 0) +decreasing_by all_goals (apply Prod.Lex.left; first | (subst_vars; assumption) | simp_wf) + +theorem Cst.Member.toAExpr?_sound + {mem : Cst.Member} {eos : Cst.ExprOrSpecial} + {req : Request} {es : Entities} : + mem.toExprOrSpecial? = some eos → + ∀ aexp, eos.toExpr? = some aexp → + evaluate aexp req es = mem.evaluate req es := by + intro hmem aexp heos + simp only [Cst.Member.toExprOrSpecial?, Option.bind_eq_bind, Option.bind_eq_some_iff] at hmem + obtain ⟨peos, hitem, accs, haccs, hmem⟩ := hmem + have hacc : sizeOf mem.access < sizeOf mem := by + cases mem; simp only [Cst.Member.mk.sizeOf_spec]; omega + have hitm : sizeOf mem.item < sizeOf mem := by + cases mem; simp only [Cst.Member.mk.sizeOf_spec]; omega + have harg : ∀ ce : Cst.Expr, sizeOf ce < sizeOf mem.access → ∀ ax, ce.toAExpr? = some ax → + evaluate ax req es = ce.evaluate req es := by + intro ce hsz ax hax + simp only [Cst.Expr.toAExpr?, Option.bind_eq_bind, Option.bind_eq_some_iff] at hax + obtain ⟨ceos, hceos, hax2⟩ := hax + exact Cst.Expr.toAExpr?_sound hceos ax hax2 + unfold Cst.Member.evaluate + split + case h_1 _ s _ args rest => + simp only [Cst.Primary.toExprOrSpecial?, Cst.Name.toVar?, Cst.Name.toAName?, + Cst.Name.toAName?, + Cst.Ident.toUnrestrictedString?, List.isEmpty_nil, Bool.not_true, Bool.false_eq_true, + reduceIte, Option.pure_def, List.mapM_nil, Option.bind_eq_bind, Option.bind_some, + Option.some.injEq] at hitem + subst hitem + rw [List.mapM_cons] at haccs + simp only [Cst.MemAccess.toAstAccessor?, Option.pure_def, Option.bind_eq_bind, + Option.bind_eq_some_iff, Option.some.injEq] at haccs + obtain ⟨a_ast, ha_ast, rest_ast, hrest_ast, rfl⟩ := haccs + obtain ⟨xs, hxs, rfl⟩ := ha_ast + have hargm : ∀ ce ∈ args, ∀ ax, ce.toAExpr? = some ax → + evaluate ax req es = ce.evaluate req es := by + intro ce hce ax hax + exact harg ce (by + have := List.sizeOf_lt_of_mem hce + simp only [Cst.MemAccess.call.sizeOf_spec, + List.cons.sizeOf_spec]; omega) ax hax + cases hfn : Cst.String.toExtFun? s with + | none => + have htf : Cst.toFunc? { id := s, path := [] } xs = none := by + simp [Cst.toFunc?, hfn] + rw [Cst.memberAux, Cst.memberAuxA, htf] at hmem + simp at hmem + | some xfn => + have htf : Cst.toFunc? { id := s, path := [] } xs = some (.call xfn xs) := by + simp [Cst.toFunc?, hfn, toExtFun?_some_isFunctionName hfn] + have hb : Cst.memberAuxB (.call xfn xs) rest_ast = some aexp := by + have hmeq : Cst.memberAux (.name { id := s, path := [] }) (.call xs :: rest_ast) + = (Cst.memberAuxB (.call xfn xs) rest_ast).bind (fun r => some (.expr r)) := by + simp [Cst.memberAux, Cst.memberAuxA, htf] + rw [hmeq] at hmem + simp only [Option.bind_eq_some_iff] at hmem + obtain ⟨ret, hret, heq2⟩ := hmem + rw [← Option.some.inj heq2] at heos + simp only [Cst.ExprOrSpecial.toExpr?, Option.some.injEq] at heos + rw [heos] at hret; exact hret + have hstep : evaluate (Expr.call xfn xs) req es = + (do let argVals ← args.mapM (fun a : Cst.Expr => a.evaluate req es); call xfn argVals) := by + simp only [evaluate, List.mapM₁_eq_mapM (fun a => evaluate a req es)] + rw [toAExprs?_eval_eq args xs hxs hargm] + rw [evalAccessors_step_eq hstep hb + (fun hv' hge => evalAccessors_eq rest rest_ast (.call xfn xs) aexp hv' + hrest_ast hb hge (fun ce hsz => harg ce (Nat.lt_trans hsz (by + simp only [Cst.MemAccess.call.sizeOf_spec, List.cons.sizeOf_spec]; omega))))] + simp [bind_assoc] + case h_2 item access hnfc => + simp only [] at hitem haccs harg + match hpe : peos.toExpr? with + | some headExpr => + have hb : Cst.memberAuxB headExpr accs = some aexp := by + have he := memberAux_toExpr_eq accs hpe + rw [hmem, Option.bind_some, heos] at he; exact he.symm + have hheadEq := @Cst.Primary.toAExpr?_sound item peos req es hitem headExpr hpe + cases hh : evaluate headExpr req es with + | error e => + rw [memberAuxB_eval_error_eq accs headExpr aexp e hb hh] + rw [← hheadEq, hh]; simp [bind, Except.bind] + | ok hv => + rw [evalAccessors_eq access accs headExpr aexp hv haccs hb hh harg] + rw [← hheadEq, hh]; simp [bind, Except.bind] + | none => + exfalso + cases memberAux_some_cases hmem with + | inl hl => obtain ⟨_, heq⟩ := hl; subst heq; rw [hpe] at heos; simp at heos + | inr hr => + obtain ⟨e, heq⟩ := hr + subst heq + cases peos with + | expr _ => simp [Cst.ExprOrSpecial.toExpr?] at hpe + | var _ => simp [Cst.ExprOrSpecial.toExpr?] at hpe + | boolLit _ => simp [Cst.ExprOrSpecial.toExpr?] at hpe + | strLit ss => + cases accs with + | nil => rw [memberAux_nil] at hmem; simp at hmem + | cons a r => simp [Cst.memberAux, Cst.memberAuxA, hpe] at hmem + | name an => + cases accs with + | nil => rw [memberAux_nil] at hmem; simp at hmem + | cons a rest_ast => + cases a with + | field id => + cases rest_ast with + | nil => simp [Cst.memberAux, Cst.memberAuxA] at hmem + | cons a2 r2 => cases a2 <;> simp [Cst.memberAux, Cst.memberAuxA] at hmem + | index id => simp [Cst.memberAux, Cst.memberAuxA] at hmem + | call xs => + cases hfunc : Cst.toFunc? an xs with + | none => simp [Cst.memberAux, Cst.memberAuxA, hfunc] at hmem + | some e'' => + simp only [Cst.toFunc?] at hfunc + split at hfunc + · rename_i hcond + simp only [Bool.and_eq_true] at hcond + obtain ⟨hpath, hfn⟩ := hcond + obtain ⟨ss, hss_kw, hs⟩ := toExprOrSpecial_name_func hitem (by simpa using hpath) hfn + cases haccess : access with + | nil => rw [haccess] at haccs; simp at haccs + | cons aa rr => + cases aa with + | call cargs => exact hnfc ss hss_kw cargs rr hs haccess + | field f => + rw [haccess] at haccs + cases f <;> + simp [List.mapM_cons, Cst.MemAccess.toAstAccessor?, + Option.bind_eq_bind, Option.bind_eq_some_iff] at haccs + | index _ => + rw [haccess] at haccs + simp [List.mapM_cons, Cst.MemAccess.toAstAccessor?, + Option.bind_eq_bind, Option.bind_eq_some_iff] at haccs + · simp at hfunc + +termination_by (sizeOf mem, 0) +decreasing_by + all_goals (apply Prod.Lex.left; first + | omega + | (subst_vars; simp only [Cst.Member.mk.sizeOf_spec] at *; omega)) + +theorem Cst.Unary.toAExpr?_sound + {u : Cst.Unary} {eos : Cst.ExprOrSpecial} + {req : Request} {es : Entities} : + u.toExprOrSpecial? = some eos → + ∀ aexp, eos.toExpr? = some aexp → + evaluate aexp req es = u.evaluate req es := by + intro hu aexp heos + have hmk : sizeOf u.item < sizeOf u := by cases u; simp only [Cst.Unary.mk.sizeOf_spec]; omega + match hop : u.op with + | none => + simp [Cst.Unary.toExprOrSpecial?, hop] at hu + simp [Cst.Unary.evaluate, hop] + exact Cst.Member.toAExpr?_sound hu aexp heos + | some (.nDash 0) => + simp [Cst.Unary.toExprOrSpecial?, hop] at hu + simp [Cst.Unary.evaluate, hop] + exact Cst.Member.toAExpr?_sound hu aexp heos + | some (.nBang n) => + simp [Cst.Unary.toExprOrSpecial?, hop] at hu + simp [Cst.Unary.evaluate, hop] + cases hitem_trans : u.item.toExprOrSpecial? with + | none => simp [hitem_trans] at hu + | some ieos => + simp [hitem_trans] at hu + cases hioes_trans : ieos.toExpr? with + | none => simp [hioes_trans] at hu + | some iexp => + simp [hioes_trans] at hu + simp [← hu, Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + have hitem_eq : evaluate iexp req es = u.item.evaluate req es := + Cst.Member.toAExpr?_sound hitem_trans iexp hioes_trans + have h_zero : (n.toNat = 0) ↔ (n = 0) := by + constructor + · intro h; exact UInt8.toNat_inj.mp (by simp [h]) + · intro h; rw [h]; rfl + have h_par : (n.toNat % 2 = 0) ↔ (n % 2 = 0) := by + rw [show n.toNat % 2 = (n % 2).toNat from by rw [UInt8.toNat_mod]; rfl] + constructor + · intro h; exact UInt8.toNat_inj.mp (by simp [h]) + · intro h; rw [h]; rfl + rw [bangN_evaluate_general iexp n.toNat req es, hitem_eq] + by_cases hn : n = 0 + · subst hn; cases hie : u.item.evaluate req es <;> simp + · have h0 : ¬ (n.toNat = 0) := fun h => hn (h_zero.mp h) + cases hie : u.item.evaluate req es with + | error e => simp [bind, Except.bind] + | ok vp => + cases vp with + | prim p => + cases p with + | bool b => + by_cases hpar : n % 2 = 0 + · simp [hn, h0, hpar, h_par.mpr hpar, bind, Except.bind] + · have hp2 : ¬ (n.toNat % 2 = 0) := fun h => hpar (h_par.mp h) + simp [hn, h0, hpar, hp2, bind, Except.bind] + | _ => simp [hn, h0, bind, Except.bind] + | _ => simp [hn, h0, bind, Except.bind] + | some (.nDash n) => + by_cases hn0 : n = 0 + · simp [hn0, Cst.Unary.toExprOrSpecial?, hop] at hu + simp [Cst.Unary.evaluate, hop, hn0] + exact Cst.Member.toAExpr?_sound hu aexp heos + · simp [Cst.Unary.toExprOrSpecial?, hop] at hu + simp [Cst.Unary.evaluate, hop, hn0] + have h_zero : (n.toNat = 0) ↔ (n = 0) := by + constructor + · intro h; exact UInt8.toNat_inj.mp (by simp [h]) + · intro h; rw [h]; rfl + have h_par : (n.toNat % 2 = 0) ↔ (n % 2 = 0) := by + rw [show n.toNat % 2 = (n % 2).toNat from by rw [UInt8.toNat_mod]; rfl] + constructor + · intro h; exact UInt8.toNat_inj.mp (by simp [h]) + · intro h; rw [h]; rfl + have hpos : n.toNat > 0 := by + by_contra h0; apply hn0; apply h_zero.mp; omega + have h_sub : (n - 1).toNat = n.toNat - 1 := by + have h1 : (UInt8.toNat 1) = 1 := by decide + rw [UInt8.toNat_sub, h1] + have hbnd : n.toNat < 256 := n.toNat_lt + omega + match hlit : Cst.Member.toLit? u.item with + | some (.liNum x) => + simp [hlit] at hu + match hcmp : compare x.toNat (Int64.MAX + 1).toNat with + | .gt => + rw [hcmp] at hu; simp at hu + | .eq => + rw [hcmp] at hu + simp at hu + simp [← hu, Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + rw [dashN_evaluate_general (Expr.lit (.int Int64.MIN.toInt64)) (n - 1).toNat req es] + simp [evaluate] + have hMIN_neg : Int64.MIN.toInt64.neg? = none := by decide + rw [hMIN_neg] + have h_eq1 : ((n - 1).toNat = 0) ↔ (n = 1) := by + constructor + · intro h + have : n - 1 = 0 := UInt8.toNat_inj.mp (by simp; exact h) + have h2 := congrArg (· + 1) this + simp at h2 + omega + · intro h; rw [h]; rfl + by_cases h1 : n = 1 + · simp [h1, hcmp] + · have h0 : ¬ ((n - 1).toNat = 0) := fun h => h1 (h_eq1.mp h) + simp [h0, h1, hcmp] + | .lt => + rw [hcmp] at hu + simp at hu + cases hofInt : Int64.ofInt? (x.toNat : Int) with + | none => rw [hofInt] at hu; cases hu + | some y => + rw [hofInt] at hu + simp at hu + simp [← hu, Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + rw [dashN_evaluate_general (Expr.lit (.int (-y))) (n - 1).toNat req es] + simp [evaluate] + have hy_neg : y.neg? = some (-y) := by + show Int64.ofInt? (-y.toInt) = some (-y) + have hround : Int64.ofInt? ((-y).toInt) = some (-y) := Int64.ofInt?_toInt (-y) + have hy_range : Int64.MIN ≤ y.toInt ∧ y.toInt ≤ Int64.MAX := by + by_contra hnr + have : Int64.ofInt? y.toInt = none := by + apply Int64.ofInt?_none_iff.mp + by_cases hlo : Int64.MIN ≤ y.toInt + · right; by_contra hhi; apply hnr; exact ⟨hlo, by omega⟩ + · left; omega + rw [Int64.ofInt?_toInt] at this; cases this + have hyti_x : y.toInt = Int.ofNat x.toNat := by + have hofInt' : Int64.ofInt? (Int.ofNat x.toNat) = some y := hofInt + have hrange' : Int64.MIN ≤ Int.ofNat x.toNat ∧ Int.ofNat x.toNat ≤ Int64.MAX := by + by_contra hnr + have : Int64.ofInt? (Int.ofNat x.toNat) = none := by + apply Int64.ofInt?_none_iff.mp + by_cases hlo : Int64.MIN ≤ Int.ofNat x.toNat + · right; by_contra hhi; apply hnr; exact ⟨hlo, by omega⟩ + · left; omega + rw [this] at hofInt'; cases hofInt' + have hsome : Int64.ofInt? (Int.ofNat x.toNat) = + some (Int64.ofInt (Int.ofNat x.toNat)) := + Int64.ofInt?_some_iff.mp hrange' + rw [hsome] at hofInt'; injection hofInt' with hyeq + rw [← hyeq] + show BitVec.toInt (BitVec.ofInt 64 (Int.ofNat x.toNat)) = Int.ofNat x.toNat + rw [BitVec.toInt_ofInt] + have hmaxv : Int64.MAX = 9223372036854775807 := by decide + have hbound : Int.ofNat x.toNat ≤ 9223372036854775807 := by + have := hrange'.2; rw [hmaxv] at this; exact this + have h1 : -(2:Int)^63 ≤ Int.ofNat x.toNat := by + have hnn : (Int.ofNat x.toNat : Int) ≥ 0 := Int.natCast_nonneg _ + have : -(2:Int)^63 = -9223372036854775808 := by decide + rw [this]; omega + have h2 : Int.ofNat x.toNat < (2:Int)^63 := by + have : (2:Int)^63 = 9223372036854775808 := by decide + rw [this]; omega + exact Int.bmod_eq_of_le h1 h2 + have hy_nonneg : y.toInt ≥ 0 := by + rw [hyti_x]; exact Int.natCast_nonneg _ + have hneg_range : Int64.MIN ≤ -y.toInt ∧ -y.toInt ≤ Int64.MAX := by + simp [Int64.MIN, Int64.MAX] at hy_range ⊢; omega + have hyti : (-y).toInt = -y.toInt := by + show BitVec.toInt (-(y.toBitVec)) = -BitVec.toInt y.toBitVec + rw [BitVec.toInt_neg] + have hy : Int64.toInt y = BitVec.toInt y.toBitVec := rfl + rw [← hy] + apply Int.bmod_eq_of_le + · simp [Int64.MIN] at hneg_range; omega + · simp [Int64.MAX] at hneg_range; omega + rw [← hyti]; exact hround + have hneg_y : (-y).neg? = some y := Int64.neg?_neg? hy_neg + rw [hneg_y] + rw [h_sub] + rcases Nat.mod_two_eq_zero_or_one n.toNat with hpar | hpar + · have hge2 : n.toNat ≥ 2 := by omega + have h1 : n.toNat - 1 ≠ 0 := by omega + have h2 : (n.toNat - 1) % 2 = 1 := by omega + have h3 : (n % 2 = 0) := h_par.mp hpar + simp [h1, h2, h3, hcmp, hofInt] + · have h3 : n % 2 ≠ 0 := by + intro hcontra + have : n.toNat % 2 = 0 := h_par.mpr hcontra + omega + by_cases h1 : n.toNat - 1 = 0 + · simp [h1, h3, hcmp, hofInt] + · have h2 : (n.toNat - 1) % 2 = 0 := by omega + simp [h1, h2, h3, hcmp, hofInt] + | some .liTrue | some .liFalse | some (.liStr _) | none => + all_goals + simp [hlit] at hu + cases hitem_trans : u.item.toExprOrSpecial? with + | none => simp [hitem_trans] at hu + | some ieos => + simp [hitem_trans] at hu + cases hioes_trans : ieos.toExpr? with + | none => simp [hioes_trans] at hu + | some iexp => + simp [hioes_trans] at hu + simp [← hu, Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + have hitem_eq : evaluate iexp req es = u.item.evaluate req es := + Cst.Member.toAExpr?_sound hitem_trans iexp hioes_trans + rw [dashN_evaluate_general iexp n.toNat req es, hitem_eq] + have h0 : ¬ (n.toNat = 0) := by omega + cases hie : u.item.evaluate req es with + | error e => simp [bind, Except.bind] + | ok vp => + cases vp with + | prim p => + cases p with + | int i => + cases hneg : i.neg? with + | none => simp [h0, hneg, bind, Except.bind] + | some j => + by_cases hpar : n % 2 = 0 + · simp [h0, hpar, h_par.mpr hpar, hneg, bind, Except.bind] + · have hp2 : ¬ (n.toNat % 2 = 0) := fun h => hpar (h_par.mp h) + simp [h0, hpar, hp2, hneg, bind, Except.bind] + | _ => simp [h0, bind, Except.bind] + | _ => simp [h0, bind, Except.bind] + +termination_by (sizeOf u, 0) +decreasing_by all_goals (apply Prod.Lex.left; (subst_vars; assumption)) + +theorem Cst.MultExpr.toAExpr?_sound + {mult : Cst.MultExpr} {eos : Cst.ExprOrSpecial} + {req : Request} {es : Entities} : + mult.toExprOrSpecial? = some eos → + ∀ aexp, eos.toExpr? = some aexp → + evaluate aexp req es = mult.evaluate req es := by + intro hmult aexp heos + have hmk : sizeOf mult.initial < sizeOf mult := by cases mult; simp only [Cst.MultExpr.mk.sizeOf_spec]; omega + have hueq : ∀ p ∈ mult.extended, ∀ (eu : Expr), p.2.toAExpr? = some eu → + evaluate eu req es = p.2.evaluate req es := by + intro p hp eu heu + have hsz : sizeOf p.2 < sizeOf mult := by + obtain ⟨mi, me⟩ := mult + have h1 := List.sizeOf_lt_of_mem hp + obtain ⟨pop, pu⟩ := p + simp only [Cst.MultExpr.mk.sizeOf_spec, Prod.mk.sizeOf_spec] at h1 ⊢ + omega + simp only [Cst.Unary.toAExpr?, Option.bind_eq_bind, Option.bind_eq_some_iff] at heu + obtain ⟨ueos, hueos, heu'⟩ := heu + exact Cst.Unary.toAExpr?_sound hueos eu heu' + match hext : mult.extended with + | [] => + simp only [Cst.MultExpr.toExprOrSpecial?, hext] at hmult + rw [@Cst.Unary.toAExpr?_sound mult.initial eos req es hmult aexp heos] + simp [Cst.MultExpr.evaluate, hext] + cases h_init : mult.initial.evaluate req es <;> + simp [bind, Except.bind, Cst.MultExpr.foldOps] + | hd :: tl => + simp [Cst.MultExpr.toExprOrSpecial?, hext, Option.bind_eq_some_iff] at hmult + obtain ⟨first, hfirst, result, hres, heos_eq⟩ := hmult + rw [← heos_eq] at heos + simp [Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + rw [hext] at hueq + rw [multExprFoldExtended_foldOps_eq req es _ hueq _ _ hres] + have hfirst_eq : evaluate first req es = mult.initial.evaluate req es := by + simp only [Cst.Unary.toAExpr?, Option.bind_eq_bind, Option.bind_eq_some_iff] at hfirst + obtain ⟨ueos, hueos, hfeu⟩ := hfirst + exact Cst.Unary.toAExpr?_sound hueos first hfeu + rw [hfirst_eq] + simp [Cst.MultExpr.evaluate, hext] + +termination_by (sizeOf mult, 0) +decreasing_by all_goals (apply Prod.Lex.left; (subst_vars; assumption)) + +theorem Cst.AddExpr.toAExpr?_sound + {add : Cst.AddExpr} {eos : Cst.ExprOrSpecial} + {req : Request} {es : Entities} : + add.toExprOrSpecial? = some eos → + ∀ aexp, eos.toExpr? = some aexp → + evaluate aexp req es = add.evaluate req es := by + intro hadd aexp heos + have hmk : sizeOf add.initial < sizeOf add := by cases add; simp only [Cst.AddExpr.mk.sizeOf_spec]; omega + have hmeq : ∀ p ∈ add.extended, ∀ (em : Expr), p.2.toAExpr? = some em → + evaluate em req es = p.2.evaluate req es := by + intro p hp em hem + have hsz : sizeOf p.2 < sizeOf add := by + obtain ⟨ai, aext⟩ := add + have h1 := List.sizeOf_lt_of_mem hp + obtain ⟨pop, pm⟩ := p + simp only [Cst.AddExpr.mk.sizeOf_spec, Prod.mk.sizeOf_spec] at h1 ⊢ + omega + simp only [Cst.MultExpr.toAExpr?, Option.bind_eq_bind, Option.bind_eq_some_iff] at hem + obtain ⟨meos, hmeos, hem'⟩ := hem + exact Cst.MultExpr.toAExpr?_sound hmeos em hem' + match hext : add.extended with + | [] => + simp only [Cst.AddExpr.toExprOrSpecial?, hext] at hadd + rw [@Cst.MultExpr.toAExpr?_sound add.initial eos req es hadd aexp heos] + simp [Cst.AddExpr.evaluate, hext] + cases h_init : add.initial.evaluate req es <;> + simp [bind, Except.bind, Cst.AddExpr.foldOps] + | hd :: tl => + simp [Cst.AddExpr.toExprOrSpecial?, hext, Option.bind_eq_some_iff] at hadd + obtain ⟨first, hfirst, result, hres, heos_eq⟩ := hadd + rw [← heos_eq] at heos + simp [Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + rw [hext] at hmeq + rw [addExprFoldExtended_foldOps_eq req es _ hmeq _ _ hres] + have hfirst_eq : evaluate first req es = add.initial.evaluate req es := by + simp only [Cst.MultExpr.toAExpr?, Option.bind_eq_bind, Option.bind_eq_some_iff] at hfirst + obtain ⟨meos, hmeos, hfem⟩ := hfirst + exact Cst.MultExpr.toAExpr?_sound hmeos first hfem + rw [hfirst_eq] + simp [Cst.AddExpr.evaluate, hext] + +termination_by (sizeOf add, 0) +decreasing_by all_goals (apply Prod.Lex.left; (subst_vars; assumption)) + +theorem Cst.Relation.toAExpr?_sound + {rel : Cst.Relation} {eos : Cst.ExprOrSpecial} + {req : Request} {es : Entities} : + rel.toExprOrSpecial? = some eos → + ∀ aexp, eos.toExpr? = some aexp → + evaluate aexp req es = rel.evaluate req es := by + intro hrel aexp heos + cases rel with + | rCommon initial extended => + match hext : extended with + | [] => + simp [Cst.Relation.toExprOrSpecial?] at hrel + rw [@Cst.AddExpr.toAExpr?_sound initial eos req es hrel aexp heos] + simp [Cst.Relation.evaluate] + | [(op, x)] => + simp [Cst.Relation.toExprOrSpecial?] at hrel + simp only [Option.bind_eq_some_iff] at hrel + obtain ⟨ieos, hieos, eFirst, hFirst, eSecond, hSecond, hres⟩ := hrel + injection hres with hres + rw [← hres] at heos + simp [Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + have hinit_eq : evaluate eFirst req es = initial.evaluate req es := + @Cst.AddExpr.toAExpr?_sound initial ieos req es hieos eFirst hFirst + simp [Cst.AddExpr.toAExpr?, Option.bind_eq_some_iff] at hSecond + obtain ⟨xeos, hxeos, hxsecond⟩ := hSecond + have hx_eq : evaluate eSecond req es = x.evaluate req es := + Cst.AddExpr.toAExpr?_sound hxeos eSecond hxsecond + cases h_init : initial.evaluate req es with + | error err => + have h_first : evaluate eFirst req es = .error err := hinit_eq.trans h_init + cases op <;> + simp [Cst.constructExprRel, evaluate, Cst.Relation.evaluate, h_first, h_init, bind, Except.bind] + | ok iv => + have h_first : evaluate eFirst req es = .ok iv := hinit_eq.trans h_init + cases h_x : x.evaluate req es with + | error err => + have h_second : evaluate eSecond req es = .error err := hx_eq.trans h_x + cases op <;> + simp [Cst.constructExprRel, evaluate, Cst.Relation.evaluate, h_first, h_second, h_init, h_x, bind, Except.bind] + | ok xv => + have h_second : evaluate eSecond req es = .ok xv := hx_eq.trans h_x + rw [constructExprRel_applyRelOp_eq op eFirst eSecond req es iv xv h_first h_second] + simp [Cst.Relation.evaluate, h_init, h_x, bind, Except.bind] + | _ :: _ :: _ => + simp [Cst.Relation.toExprOrSpecial?] at hrel + | rHas target field => + simp [Cst.Relation.toExprOrSpecial?, Option.bind_eq_some_iff] at hrel + obtain ⟨mt, hmt, mf, hmf, hres⟩ := hrel + simp [Cst.AddExpr.toAExpr?, Option.bind_eq_some_iff] at hmt + obtain ⟨tEos, htEos, htExpr⟩ := hmt + have htarget_eq : evaluate mt req es = target.evaluate req es := + @Cst.AddExpr.toAExpr?_sound target tEos req es htEos mt htExpr + have hfield_attrs := addExpr_toHasRhs_toAttrs_agrees hmf + have hfield_nonempty := hasRhsToList_nonempty hmf + simp [Cst.Relation.evaluate, hfield_attrs] + cases mf with + | inl f => + simp at hres + rw [← hres] at heos + simp [Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + simp [hasRhsToList] + cases htgt : target.evaluate req es with + | error err => + have hmtE : evaluate mt req es = .error err := htarget_eq.trans htgt + simp [evaluate, hmtE, bind, Except.bind] + | ok vt => + have hmtO : evaluate mt req es = .ok vt := htarget_eq.trans htgt + simp [evaluate, hmtO, bind, Except.bind, Cst.rHasChain] + | inr fs => + simp at hres + rw [← hres] at heos + simp [Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + simp [hasRhsToList] at hfield_attrs hfield_nonempty + cases hfs : fs with + | nil => rw [hfs] at hfield_nonempty; simp at hfield_nonempty + | cons a as => + rw [hfs] at hfield_attrs + cases htgt : target.evaluate req es with + | error err => + have htgtMt : evaluate mt req es = .error err := htarget_eq.trans htgt + cases as with + | nil => simp [Cst.extendedHasAttr, evaluate, htgtMt, bind, Except.bind] + | cons b bs => simp [Cst.extendedHasAttr, evaluate, htgtMt, bind, Except.bind, Result.as] + | ok vt => + have htgtMt : evaluate mt req es = .ok vt := htarget_eq.trans htgt + rw [extendedHasAttr_evaluate_agrees mt a as req es vt htgtMt] + simp [hasRhsToList, bind, Except.bind] + | rLike target pattern => + simp [Cst.Relation.toExprOrSpecial?, Option.bind_eq_some_iff] at hrel + obtain ⟨mt, hmt, mp, hmp, hres⟩ := hrel + rw [← hres] at heos + simp [Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + simp [Cst.AddExpr.toAExpr?, Option.bind_eq_some_iff] at hmt + obtain ⟨tEos, htEos, htExpr⟩ := hmt + have htarget_eq : evaluate mt req es = target.evaluate req es := + @Cst.AddExpr.toAExpr?_sound target tEos req es htEos mt htExpr + obtain ⟨s, hpStr, hpToPattern⟩ := addExpr_toPattern_toPatternString_agrees hmp + simp [Cst.Relation.evaluate, hpStr] + cases htgt : target.evaluate req es with + | error err => + have hmtE : evaluate mt req es = .error err := htarget_eq.trans htgt + simp [evaluate, hmtE, bind, Except.bind] + | ok vt => + have hmtO : evaluate mt req es = .ok vt := htarget_eq.trans htgt + simp [evaluate, hmtO, bind, Except.bind, hpToPattern] + | rIsIn target ety inEntity => + simp [Cst.Relation.toExprOrSpecial?, Option.bind_eq_some_iff] at hrel + have ⟨mt, hmt, et, hEt, hMatch⟩ := hrel + match hinE : inEntity, hMatch with + | none, hMatch => + simp at hMatch + subst hMatch + simp [Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + simp [Cst.AddExpr.toAExpr?, Option.bind_eq_some_iff] at hmt + have ⟨tEos, htEos, htExpr⟩ := hmt + have htarget_eq : evaluate mt req es = target.evaluate req es := + @Cst.AddExpr.toAExpr?_sound target tEos req es htEos mt htExpr + simp [Cst.Relation.evaluate, hEt] + cases htgt : target.evaluate req es with + | error err => + have hmtE : evaluate mt req es = .error err := htarget_eq.trans htgt + simp [evaluate, hmtE, bind, Except.bind] + | ok vt => + have hmtO : evaluate mt req es = .ok vt := htarget_eq.trans htgt + simp [evaluate, hmtO, bind, Except.bind] + cases apply₁ (UnaryOp.is et) vt <;> simp + | some ie, hMatch => + simp [Option.bind_eq_some_iff] at hMatch + have ⟨mi, hmi, hres⟩ := hMatch + subst hres + simp [Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + simp [Cst.AddExpr.toAExpr?, Option.bind_eq_some_iff] at hmt + have ⟨tEos, htEos, htExpr⟩ := hmt + have htarget_eq : evaluate mt req es = target.evaluate req es := + @Cst.AddExpr.toAExpr?_sound target tEos req es htEos mt htExpr + have hie_trans : ie.toAExpr? = some mi := hmi + simp [Cst.AddExpr.toAExpr?, Option.bind_eq_some_iff] at hmi + have ⟨iEos, hiEos, hiExpr⟩ := hmi + have hinEntity_eq : evaluate mi req es = ie.evaluate req es := + @Cst.AddExpr.toAExpr?_sound ie iEos req es hiEos mi hiExpr + exact rIsIn_some_eval_eq hEt htarget_eq hinEntity_eq hie_trans + +termination_by (sizeOf rel, 0) +decreasing_by + all_goals + apply Prod.Lex.left + subst_vars + simp only [Cst.Relation.rCommon.sizeOf_spec, Cst.Relation.rHas.sizeOf_spec, + Cst.Relation.rLike.sizeOf_spec, Cst.Relation.rIsIn.sizeOf_spec, + List.cons.sizeOf_spec, Prod.mk.sizeOf_spec, Option.some.sizeOf_spec] at * + omega + +theorem Cst.AndExpr.toAExpr?_sound + {ae : Cst.AndExpr} {eos : Cst.ExprOrSpecial} + {req : Request} {es : Entities} : + ae.toExprOrSpecial? = some eos → + ∀ aexp, eos.toExpr? = some aexp → + evaluate aexp req es = ae.evaluate req es := by + intro hae aexp heos + have hmk : sizeOf ae.initial < sizeOf ae := by cases ae; simp only [Cst.AndExpr.mk.sizeOf_spec]; omega + have hreq : ∀ r ∈ ae.extended, ∀ (er : Expr), r.toAExpr? = some er → + evaluate er req es = r.evaluate req es := by + intro r hr er her + have hsz : sizeOf r < sizeOf ae := by + obtain ⟨ai, aext⟩ := ae + have h1 := List.sizeOf_lt_of_mem hr + simp only [Cst.AndExpr.mk.sizeOf_spec] at h1 ⊢ + omega + simp only [Cst.Relation.toAExpr?, Option.bind_eq_bind, Option.bind_eq_some_iff] at her + obtain ⟨reos, hreos, her'⟩ := her + exact Cst.Relation.toAExpr?_sound hreos er her' + match hext : ae.extended with + | [] => + simp only [Cst.AndExpr.toExprOrSpecial?, hext] at hae + rw [@Cst.Relation.toAExpr?_sound ae.initial eos req es hae aexp heos] + simp [Cst.AndExpr.evaluate, hext] + cases h_init : ae.initial.evaluate req es <;> + simp [bind, Except.bind, Cst.AndExpr.foldOps] + | hd :: tl => + simp [Cst.AndExpr.toExprOrSpecial?, hext, Option.bind_eq_some_iff] at hae + obtain ⟨first, hfirst, result, hres, heos_eq⟩ := hae + rw [← heos_eq] at heos + simp [Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + rw [hext] at hreq + rw [andExprFoldExtended_foldOps_eq req es _ hreq _ _ hres] + have hfirst_eq : evaluate first req es = ae.initial.evaluate req es := by + simp only [Cst.Relation.toAExpr?, Option.bind_eq_bind, Option.bind_eq_some_iff] at hfirst + obtain ⟨reos, hreos, hfem⟩ := hfirst + exact Cst.Relation.toAExpr?_sound hreos first hfem + rw [hfirst_eq] + have hall := andExprFoldExtended_some_all_translate _ hres + have hguard : (ae.extended.all fun r => r.toAExpr?.isSome) = true := by rw [hext]; exact hall + rw [AndExpr.evaluate_eq hguard, hext] + +termination_by (sizeOf ae, 0) +decreasing_by all_goals (apply Prod.Lex.left; (subst_vars; assumption)) + +theorem Cst.OrExpr.toAExpr?_sound + {oe : Cst.OrExpr} {eos : Cst.ExprOrSpecial} + {req : Request} {es : Entities} : + oe.toExprOrSpecial? = some eos → + ∀ aexp, eos.toExpr? = some aexp → + evaluate aexp req es = oe.evaluate req es := by + intro hoe aexp heos + have hmk : sizeOf oe.initial < sizeOf oe := by cases oe; simp only [Cst.OrExpr.mk.sizeOf_spec]; omega + have hareq : ∀ a ∈ oe.extended, ∀ (ea : Expr), a.toAExpr? = some ea → + evaluate ea req es = a.evaluate req es := by + intro a ha ea hea + have hsz : sizeOf a < sizeOf oe := by + obtain ⟨oi, oext⟩ := oe + have h1 := List.sizeOf_lt_of_mem ha + simp only [Cst.OrExpr.mk.sizeOf_spec] at h1 ⊢ + omega + simp only [Cst.AndExpr.toAExpr?, Option.bind_eq_bind, Option.bind_eq_some_iff] at hea + obtain ⟨aeos, haeos, hea'⟩ := hea + exact Cst.AndExpr.toAExpr?_sound haeos ea hea' + match hext : oe.extended with + | [] => + simp only [Cst.OrExpr.toExprOrSpecial?, hext] at hoe + rw [@Cst.AndExpr.toAExpr?_sound oe.initial eos req es hoe aexp heos] + simp [Cst.OrExpr.evaluate, hext] + cases h_init : oe.initial.evaluate req es <;> + simp [bind, Except.bind, Cst.OrExpr.foldOps] + | hd :: tl => + simp [Cst.OrExpr.toExprOrSpecial?, hext, Option.bind_eq_some_iff] at hoe + obtain ⟨first, hfirst, result, hres, heos_eq⟩ := hoe + rw [← heos_eq] at heos + simp [Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + rw [hext] at hareq + rw [orExprFoldExtended_foldOps_eq req es _ hareq _ _ hres] + have hfirst_eq : evaluate first req es = oe.initial.evaluate req es := by + simp only [Cst.AndExpr.toAExpr?, Option.bind_eq_bind, Option.bind_eq_some_iff] at hfirst + obtain ⟨aeos, haeos, hfea⟩ := hfirst + exact Cst.AndExpr.toAExpr?_sound haeos first hfea + rw [hfirst_eq] + have hall := orExprFoldExtended_some_all_translate _ hres + have hguard : (oe.extended.all fun r => r.toAExpr?.isSome) = true := by rw [hext]; exact hall + rw [OrExpr.evaluate_eq hguard, hext] + +termination_by (sizeOf oe, 0) +decreasing_by all_goals (apply Prod.Lex.left; (subst_vars; assumption)) + +theorem Cst.ExprData.toAExpr?_sound + {ed : Cst.ExprData} {eos : Cst.ExprOrSpecial} + {req : Request} {es : Entities} : + ed.toExprOrSpecial? = some eos → + ∀ aexp, eos.toExpr? = some aexp → + evaluate aexp req es = ed.evaluate req es := by + intro hed aexp heos + cases ed with + | edOr ore => + simp [Cst.ExprData.toExprOrSpecial?] at hed + simp [Cst.ExprData.evaluate] + have hsz : sizeOf ore < sizeOf (Cst.ExprData.edOr ore) := by + simp only [Cst.ExprData.edOr.sizeOf_spec]; omega + exact Cst.OrExpr.toAExpr?_sound hed aexp heos + | edIf i t f => + simp [Cst.ExprData.toExprOrSpecial?, Option.bind_eq_some_iff] at hed + obtain ⟨eg, hg, et, ht, ef, hf, hres⟩ := hed + have hguard : (t.toAExpr?.isSome && f.toAExpr?.isSome) = true := by simp [ht, hf] + rw [← hres] at heos + simp [Cst.ExprOrSpecial.toExpr?] at heos + rw [← heos] + simp [Cst.Expr.toAExpr?, Option.bind_eq_some_iff] at hg ht hf + obtain ⟨gEos, hgEos, hgExpr⟩ := hg + obtain ⟨tEos, htEos, htExpr⟩ := ht + obtain ⟨fEos, hfEos, hfExpr⟩ := hf + have hszi : sizeOf i < sizeOf (Cst.ExprData.edIf i t f) := by + simp only [Cst.ExprData.edIf.sizeOf_spec]; omega + have hszt : sizeOf t < sizeOf (Cst.ExprData.edIf i t f) := by + simp only [Cst.ExprData.edIf.sizeOf_spec]; omega + have hszf : sizeOf f < sizeOf (Cst.ExprData.edIf i t f) := by + simp only [Cst.ExprData.edIf.sizeOf_spec]; omega + have hg_eq : evaluate eg req es = i.evaluate req es := Cst.Expr.toAExpr?_sound hgEos eg hgExpr + have ht_eq : evaluate et req es = t.evaluate req es := Cst.Expr.toAExpr?_sound htEos et htExpr + have hf_eq : evaluate ef req es = f.evaluate req es := Cst.Expr.toAExpr?_sound hfEos ef hfExpr + rw [ExprData.evaluate_edIf_eq hguard] + simp [evaluate, bind, Except.bind, Result.as, Coe.coe] + rw [hg_eq] + cases hi : i.evaluate req es with + | error err => simp + | ok gv => + cases gv with + | prim p => + cases p with + | bool b => + simp [Value.asBool] + cases b with + | true => exact ht_eq + | false => exact hf_eq + | int _ | string _ | entityUID _ => simp [Value.asBool] + | set _ | record _ | ext _ => simp [Value.asBool] +termination_by (sizeOf ed, 0) +decreasing_by all_goals (apply Prod.Lex.left; (subst_vars; assumption)) + +theorem Cst.ExprImpl.toAExpr?_sound + {ei : Cst.ExprImpl} {eos : Cst.ExprOrSpecial} + {req : Request} {es : Entities} : + ei.toExprOrSpecial? = some eos → + ∀ aexp, eos.toExpr? = some aexp → + evaluate aexp req es = ei.evaluate req es := by + intro hei aexp heos + simp only [Cst.ExprImpl.toExprOrSpecial?] at hei + simp [Cst.ExprImpl.evaluate] + exact Cst.ExprData.toAExpr?_sound hei aexp heos +termination_by (sizeOf ei, 0) +decreasing_by + apply Prod.Lex.left + have h : sizeOf ei = 1 + sizeOf ei.expr := by cases ei; simp [Cst.ExprImpl.mk.sizeOf_spec] + omega + +theorem Cst.Expr.toAExpr?_sound + {e : Cst.Expr} {eos : Cst.ExprOrSpecial} + {req : Request} {es : Entities} : + e.toExprOrSpecial? = some eos → + ∀ aexp, eos.toExpr? = some aexp → + evaluate aexp req es = e.evaluate req es := by + intro he aexp heos + cases e with + | expr ei => + simp only [Cst.Expr.toExprOrSpecial?] at he + simp [Cst.Expr.evaluate] + have hsz : sizeOf ei < sizeOf (Cst.Expr.expr ei) := by + simp only [Cst.Expr.expr.sizeOf_spec]; omega + exact Cst.ExprImpl.toAExpr?_sound he aexp heos +termination_by (sizeOf e, 0) +decreasing_by all_goals (apply Prod.Lex.left; (subst_vars; assumption)) + +theorem expr_to_expr_sound + {e : Cst.Expr} {aexp : Expr} {req : Request} {es : Entities} : + e.toAExpr? = some aexp → + evaluate aexp req es = e.evaluate req es := by + intro h + simp [Cst.Expr.toAExpr?] at h + cases heos : e.toExprOrSpecial? with + | none => simp [heos] at h + | some eos => + apply Cst.Expr.toAExpr?_sound heos aexp + simp [heos] at h; exact h + +end diff --git a/cedar-lean/Cedar/Thm/Frontend/Translation/PolicyToExpr.lean b/cedar-lean/Cedar/Thm/Frontend/Translation/PolicyToExpr.lean new file mode 100644 index 000000000..4fb5bc5ee --- /dev/null +++ b/cedar-lean/Cedar/Thm/Frontend/Translation/PolicyToExpr.lean @@ -0,0 +1,625 @@ +import Cedar.Spec +import Cedar.Frontend.Cst +import Cedar.Frontend.Cst.Semantics +import Cedar.Frontend.Cst.ToAst +import Cedar.Thm.Frontend.Translation.AuxSound +import Cedar.Thm.Data.List.Lemmas +import Cedar.Thm.Data.Set +import Cedar.Thm.Data.List.Canonical + +namespace Cedar.Thm + +open Cedar.Data +open Cedar.Spec +open Cedar.Frontend + +/-! ## Proof structure for `policy_to_expr_sound` + +Both translation paths are rearrangements of a left-folded AST conjunction over +a common leaf list `[principalScope, actionScope, resourceScope, conds…]`. The +proof factors into four layers: + A. generic algebra of AST `.and` (path-independent), + B. path 1 translation (`Cst` `foldAnd` → `bigAnd`), + C. path 2 normalization (`Policy.toExpr` → `bigAnd`), + D. per-leaf semantic agreement. +The main theorem just composes them. -/ + +/- ===== Layer A: algebra of AST conjunction ===== -/ + +/-- Left-nested AST conjunction; the common normal form for both paths. -/ +def bigAnd (a : Expr) (rest : List Expr) : Expr := + rest.foldl (fun acc e => acc.and e) a + +/-- Normal form of evaluating an AST `.and`. -/ +theorem evaluate_and_eq (x y : Expr) (req : Request) (es : Entities) : + evaluate (.and x y) req es = + match (evaluate x req es).as Bool with + | .error e => .error e + | .ok false => .ok (.prim (.bool false)) + | .ok true => (evaluate y req es).as Bool := by + simp only [evaluate] + cases h : (evaluate x req es).as Bool with + | error e => simp [bind, Except.bind] + | ok b => cases b <;> simp [bind, Except.bind] + +/-- `.and` is associative over the full evaluation `Result` (incl. error and + short-circuit behavior). This is what makes left- vs right-nesting agree. -/ +theorem evaluate_and_assoc (a b c : Expr) (req : Request) (es : Entities) : + evaluate (.and (.and a b) c) req es = evaluate (.and a (.and b c)) req es := by + rw [evaluate_and_eq (.and a b) c, evaluate_and_eq a b, + evaluate_and_eq a (.and b c), evaluate_and_eq b c] + cases ha : (evaluate a req es).as Bool with + | error e => simp [Result.as] + | ok ba => + cases ba with + | false => simp [Result.as, Coe.coe, Value.asBool] + | true => + cases hb : (evaluate b req es).as Bool with + | error e => simp [Result.as, bind, Except.bind] + | ok bb => + cases bb with + | false => simp [Result.as, Coe.coe, Value.asBool, bind, Except.bind, pure, Except.pure] + | true => + cases hc : (evaluate c req es).as Bool <;> + simp [Result.as, Coe.coe, Value.asBool, bind, Except.bind, pure, Except.pure] + +/-- `x` only ever evaluates to a bool or an error (true for every scope expr). -/ +def Boolish (x : Expr) (req : Request) (es : Entities) : Prop := + ∀ v, evaluate x req es = .ok v → ∃ b : Bool, v = .prim (.bool b) + +/-- Right identity `… ∧ true ≡ …` on boolish exprs (the empty-conditions case). -/ +theorem evaluate_and_true (x : Expr) (req : Request) (es : Entities) : + Boolish x req es → + evaluate (.and x (.lit (.bool true))) req es = evaluate x req es := by + intro h + rw [evaluate_and_eq] + cases hx : evaluate x req es with + | error e => simp [Result.as] + | ok v => + obtain ⟨b, rfl⟩ := h v hx + cases b <;> + simp [Result.as, Coe.coe, Value.asBool, Functor.map, Except.map, evaluate] + +/-- `AndExpr.foldExtended` over lifted relations is exactly `bigAnd`. -/ +theorem foldExtended_eq_bigAnd (acc : Expr) (l : List Cst.Expr) (aes : List Expr) : + l.mapM Cst.Expr.toAExpr? = some aes → + Cst.AndExpr.foldExtended acc (l.map Cst.Expr.toRelation) = some (bigAnd acc aes) := by + induction l generalizing acc aes with + | nil => + intro h + simp only [List.mapM_nil, Option.pure_def, Option.some.injEq] at h + subst h + simp [Cst.AndExpr.foldExtended, bigAnd] + | cons e es ih => + intro h + simp [List.mapM_cons, Option.bind_eq_some_iff] at h + obtain ⟨ahead, hhead, atl, htl, heq⟩ := h + subst heq + have hih := ih (acc.and ahead) atl htl + simp only [List.map_cons, Cst.AndExpr.foldExtended, toRelation_toAExpr, hhead, bind, + Option.bind, hih, bigAnd, List.foldl_cons] + +/-- Translating a CST `foldAnd` yields the `bigAnd` of the translated leaves. -/ +theorem foldAnd_toAExpr (l : List Cst.Expr) (as : List Expr) : + l.mapM Cst.Expr.toAExpr? = some as → + (Cst.Expr.foldAnd l).toAExpr? = + some (match as with + | [] => .lit (.bool true) + | a :: rest => bigAnd a rest) := by + intro h + cases l with + | nil => + simp only [List.mapM_nil, Option.pure_def, Option.some.injEq] at h + subst h + simp [Cst.Expr.foldAnd, Cst.Expr.tt, Cst.Primary.toMember, Cst.Member.toUnary, + Cst.Unary.toMultExpr, Cst.MultExpr.toAddExpr, Cst.AddExpr.toRelation, Cst.Relation.toAndExpr, + Cst.AndExpr.toOrExpr, Cst.OrExpr.toExpr, Cst.Expr.toAExpr?, Cst.Expr.toExprOrSpecial?, + Cst.ExprImpl.toExprOrSpecial?, Cst.ExprData.toExprOrSpecial?, Cst.OrExpr.toExprOrSpecial?, + Cst.AndExpr.toExprOrSpecial?, Cst.Relation.toExprOrSpecial?, Cst.AddExpr.toExprOrSpecial?, + Cst.MultExpr.toExprOrSpecial?, Cst.Unary.toExprOrSpecial?, Cst.Member.toExprOrSpecial?, + Cst.Primary.toExprOrSpecial?, Cst.Literal.toExprOrSpecial?, + Cst.memberAuxA, Cst.memberAux, Cst.ExprOrSpecial.toExpr?] + | cons e tl => + cases tl with + | nil => + cases hhead : e.toAExpr? with + | none => simp [List.mapM_cons, hhead] at h + | some ahead => + simp [List.mapM_cons, List.mapM_nil, hhead] at h + subst h + simp [Cst.Expr.foldAnd, hhead, bigAnd] + | cons f es => + rw [List.mapM_cons] at h + simp [Option.bind_eq_some_iff] at h + obtain ⟨ahead, hhead, atl, htl, heq⟩ := h + subst heq + have htl' : (f :: es).mapM Cst.Expr.toAExpr? = some atl := by + simp [List.mapM_cons, Option.bind_eq_some_iff]; exact htl + have hfold := foldExtended_eq_bigAnd ahead (f :: es) atl htl' + simp only [List.map_cons] at hfold + simp [Cst.Expr.foldAnd, Cst.AndExpr.toOrExpr, Cst.OrExpr.toExpr, + Cst.Expr.toAExpr?, Cst.Expr.toExprOrSpecial?, Cst.ExprImpl.toExprOrSpecial?, + Cst.ExprData.toExprOrSpecial?, Cst.OrExpr.toExprOrSpecial?, Cst.AndExpr.toExprOrSpecial?, + toRelation_toAExpr, hhead, hfold, Cst.ExprOrSpecial.toExpr?] + +/-- Inversion of `foldExtended_eq_bigAnd`: if the fold succeeds, every leaf + translates and the result is `bigAnd`. -/ +theorem foldExtended_inv (acc : Expr) (l : List Cst.Expr) (result : Expr) : + Cst.AndExpr.foldExtended acc (l.map Cst.Expr.toRelation) = some result → + ∃ aes, l.mapM Cst.Expr.toAExpr? = some aes ∧ result = bigAnd acc aes := by + induction l generalizing acc result with + | nil => + intro h + simp only [List.map_nil, Cst.AndExpr.foldExtended, Option.some.injEq] at h + exact ⟨[], by simp [List.mapM_nil], by simp [bigAnd, ← h]⟩ + | cons e es ih => + intro h + cases ha0 : e.toAExpr? with + | none => + simp [List.map_cons, Cst.AndExpr.foldExtended, toRelation_toAExpr, ha0] at h + | some a0 => + simp only [List.map_cons, Cst.AndExpr.foldExtended, toRelation_toAExpr, ha0, bind, + Option.bind] at h + obtain ⟨atl, hatl, hres⟩ := ih (acc.and a0) result h + refine ⟨a0 :: atl, ?_, ?_⟩ + · simp [List.mapM_cons, ha0, hatl] + · subst hres; simp [bigAnd, List.foldl_cons] + +/-- Inversion of `foldAnd_toAExpr`. -/ +theorem foldAnd_inv (l : List Cst.Expr) (ae : Expr) : + (Cst.Expr.foldAnd l).toAExpr? = some ae → + ∃ as, l.mapM Cst.Expr.toAExpr? = some as ∧ + ae = (match as with | [] => .lit (.bool true) | a :: rest => bigAnd a rest) := by + intro h + cases l with + | nil => + refine ⟨[], by simp [List.mapM_nil], ?_⟩ + open Cst in simp [Expr.foldAnd, Expr.tt, Primary.toMember, Member.toUnary, + Unary.toMultExpr, MultExpr.toAddExpr, AddExpr.toRelation, Relation.toAndExpr, + AndExpr.toOrExpr, OrExpr.toExpr, Expr.toAExpr?, Expr.toExprOrSpecial?, + ExprImpl.toExprOrSpecial?, ExprData.toExprOrSpecial?, OrExpr.toExprOrSpecial?, + AndExpr.toExprOrSpecial?, Relation.toExprOrSpecial?, AddExpr.toExprOrSpecial?, + MultExpr.toExprOrSpecial?, Unary.toExprOrSpecial?, Member.toExprOrSpecial?, + Primary.toExprOrSpecial?, Literal.toExprOrSpecial?, memberAuxA, memberAux, + ExprOrSpecial.toExpr?] at h + simp [← h] + | cons e tl => + cases tl with + | nil => + cases hhead : e.toAExpr? with + | none => simp [Cst.Expr.foldAnd, hhead] at h + | some ahead => + refine ⟨[ahead], by simp [List.mapM_cons, List.mapM_nil, hhead], ?_⟩ + simp only [Cst.Expr.foldAnd, hhead, Option.some.injEq] at h + simp [bigAnd, ← h] + | cons f es => + cases hhead : e.toAExpr? with + | none => + open Cst in simp [Expr.foldAnd, AndExpr.toOrExpr, Cst.OrExpr.toExpr, Cst.Expr.toAExpr?, + Cst.Expr.toExprOrSpecial?, Cst.ExprImpl.toExprOrSpecial?, Cst.ExprData.toExprOrSpecial?, + Cst.OrExpr.toExprOrSpecial?, Cst.AndExpr.toExprOrSpecial?, toRelation_toAExpr, hhead, + ExprOrSpecial.toExpr?] at h + | some ahead => + open Cst in simp only [Expr.foldAnd, AndExpr.toOrExpr, OrExpr.toExpr, Expr.toAExpr?, + Expr.toExprOrSpecial?, ExprImpl.toExprOrSpecial?, ExprData.toExprOrSpecial?, + OrExpr.toExprOrSpecial?, AndExpr.toExprOrSpecial?, List.map_cons, + toRelation_toAExpr, hhead, ExprOrSpecial.toExpr?, bind, Option.bind] at h + cases hfold : Cst.AndExpr.foldExtended ahead (f.toRelation :: es.map Cst.Expr.toRelation) with + | none => rw [hfold] at h; simp at h + | some result => + rw [hfold] at h + simp only [Option.some.injEq] at h + obtain ⟨atl, hatl, hres⟩ := foldExtended_inv ahead (f :: es) result hfold + refine ⟨ahead :: atl, ?_, ?_⟩ + · simp [List.mapM_cons, hhead, hatl] + · subst hres; exact h.symm + +/- ===== Layer C: path 2 normalization (`Policy.toExpr` → `bigAnd`) ===== -/ + +/-- Head-recursion for `Conditions.toExpr` (which is defined via a reverse-fold). -/ +theorem conditions_toExpr_cons (c : Condition) (cs : Conditions) : + Conditions.toExpr (c :: cs) = + match cs with + | [] => c.toExpr + | _ => c.toExpr.and (Conditions.toExpr cs) := by + cases hrev : cs.reverse with + | nil => + have hcs : cs = [] := by have := congrArg List.reverse hrev; simpa using this + subst hcs; simp [Conditions.toExpr] + | cons e t => + obtain ⟨hd, tl, rfl⟩ : ∃ hd tl, cs = hd :: tl := by + cases cs with + | nil => simp at hrev + | cons hd tl => exact ⟨hd, tl, rfl⟩ + simp only [Conditions.toExpr, List.reverse_cons, hrev, List.cons_append, + List.foldl_append, List.foldl_cons, List.foldl_nil] + +/-- Any AST `.and` only ever evaluates to a bool or an error. -/ +theorem and_Boolish (x y : Expr) (req : Request) (es : Entities) : + Boolish (Expr.and x y) req es := by + intro v hv + rw [evaluate_and_eq] at hv + split at hv + · simp at hv + · exact ⟨false, by simp_all⟩ + · cases hy : (evaluate y req es).as Bool with + | error e => rw [hy] at hv; simp [bind, Except.bind] at hv + | ok a => + rw [hy] at hv + simp [bind, Except.bind, pure, Except.pure] at hv + exact ⟨a, hv.symm⟩ + +/-- Flatten a trailing `Conditions.toExpr` into the left-folded `bigAnd`. -/ +theorem cond_flatten (acc : Expr) (cs : Conditions) (req : Request) (es : Entities) + (hb : Boolish acc req es) : + evaluate (acc.and (Conditions.toExpr cs)) req es = + evaluate (bigAnd acc (cs.map Condition.toExpr)) req es := by + induction cs generalizing acc with + | nil => + simp only [Conditions.toExpr, List.reverse_nil, List.map_nil, bigAnd, List.foldl_nil] + exact evaluate_and_true acc req es hb + | cons c cs' ih => + cases cs' with + | nil => rw [conditions_toExpr_cons]; simp [bigAnd] + | cons d ds => + rw [conditions_toExpr_cons] + dsimp only + rw [← evaluate_and_assoc, ih (acc.and c.toExpr) (and_Boolish acc c.toExpr req es)] + simp [bigAnd, List.map_cons] + +/-- `Policy.toExpr` evaluates as `bigAnd` over its flattened leaves. Uses + `evaluate_and_assoc` for the fixed nesting / condition flattening, and + `evaluate_and_true` (with `Boolish` of the resource-scope leaf) to drop the + trailing `true` when `condition = []`. -/ +theorem evaluate_policy_toExpr (ap : Policy) (req : Request) (es : Entities) : + evaluate ap.toExpr req es = + evaluate (bigAnd ap.principalScope.toExpr + (ap.actionScope.toExpr :: ap.resourceScope.toExpr :: + ap.condition.map Condition.toExpr)) req es := by + unfold Spec.Policy.toExpr + rw [← evaluate_and_assoc] + rw [← evaluate_and_assoc] + rw [cond_flatten _ ap.condition req es (and_Boolish _ _ req es)] + simp [bigAnd] + +/- ===== Layer D: per-leaf agreement ===== -/ + +/-- Shared core: the principal/resource leaf equals `Scope.toExpr scope v`, + given the scope variable translates to `Expr.var v`. -/ +theorem toPRScope_leaf {vd : Cst.VariableDef} {scope : Scope} {leaf : Expr} {v : Var} + (hv : (vd.var.varToAddExpr).toExprOrSpecial? = some (Cst.ExprOrSpecial.var v)) + (hscope : vd.toPRScope? = some scope) + (hleaf : vd.toExpr.toAExpr? = some leaf) : + leaf = Scope.toExpr scope v := by + have collapse : ∀ r : Cst.Relation, + ({initial := r, extended := []} : Cst.AndExpr).toOrExpr.toExpr.toAExpr? = r.toAExpr? := by + intro r + simp [Cst.AndExpr.toOrExpr, Cst.OrExpr.toExpr, Cst.Expr.toAExpr?, Cst.Expr.toExprOrSpecial?, + Cst.ExprImpl.toExprOrSpecial?, Cst.ExprData.toExprOrSpecial?, Cst.OrExpr.toExprOrSpecial?, + Cst.AndExpr.toExprOrSpecial?, Cst.Relation.toAExpr?] + obtain ⟨var, et, ineq⟩ := vd + have hv2 : (var.varToAddExpr).toAExpr? = some (Expr.var v) := by + simp [Cst.AddExpr.toAExpr?, hv, Cst.ExprOrSpecial.toExpr?] + simp only [Cst.VariableDef.toExpr, Cst.VariableDef.toAndExpr] at hleaf + match ineq, et, hscope with + | none, none, hscope => + simp only [Cst.VariableDef.toPRScope?, Option.some.injEq] at hscope + subst hscope + rw [collapse] at hleaf + open Cst in simp only [Relation.tt, Primary.toMember, Member.toUnary, Unary.toMultExpr, + MultExpr.toAddExpr, AddExpr.toRelation, Relation.toAExpr?, + Relation.toExprOrSpecial?, AddExpr.toExprOrSpecial?, MultExpr.toExprOrSpecial?, + Unary.toExprOrSpecial?, Member.toExprOrSpecial?, Primary.toExprOrSpecial?, + Literal.toExprOrSpecial?, memberAuxA, memberAux, ExprOrSpecial.toExpr?] at hleaf + simp_all [Scope.toExpr] + | none, some t, hscope => + simp [Cst.VariableDef.toPRScope?, Option.bind_eq_some_iff] at hscope + obtain ⟨ety, hety, hsc⟩ := hscope + subst hsc + rw [collapse] at hleaf + open Cst in simp [ + Relation.toAExpr?, Relation.toExprOrSpecial?, hv2, hety, ExprOrSpecial.toExpr? + ] at hleaf + simp_all [Scope.toExpr, Var.isEntityType] + | some (.rEq, e), none, hscope => + simp [Cst.VariableDef.toPRScope?, Option.bind_eq_some_iff] at hscope + obtain ⟨uid, huid, hsc⟩ := hscope + subst hsc + rw [collapse] at hleaf + open Cst in simp [ + Relation.toAExpr?, Relation.toExprOrSpecial?, hv, constructExprRel, + toAddExpr_toAExpr, toEntityUID_toAExpr huid, ExprOrSpecial.toExpr?, + ] at hleaf + simp_all [Scope.toExpr, Var.eqEntityUID] + | some (.rIn, e), none, hscope => + simp [Cst.VariableDef.toPRScope?, Option.bind_eq_some_iff] at hscope + obtain ⟨uid, huid, hsc⟩ := hscope + subst hsc + rw [collapse] at hleaf + open Cst in simp [Relation.toAExpr?, Relation.toExprOrSpecial?, hv, constructExprRel, + toAddExpr_toAExpr, toEntityUID_toAExpr huid, ExprOrSpecial.toExpr?, + ] at hleaf + simp_all [Scope.toExpr, Var.inEntityUID] + | some (.rIn, e), some t, hscope => + simp [Cst.VariableDef.toPRScope?, Option.bind_eq_some_iff] at hscope + obtain ⟨uid, huid, ety, hety, hsc⟩ := hscope + subst hsc + rw [collapse] at hleaf + open Cst in simp [Relation.toAExpr?, Relation.toExprOrSpecial?, hv2, hety, + toAddExpr_toAExpr, toEntityUID_toAExpr huid, ExprOrSpecial.toExpr?, + ] at hleaf + simp_all [Scope.toExpr, Var.inEntityUID, Var.isEntityType] + | some (.rEq, e), some t, hscope => simp [Cst.VariableDef.toPRScope?] at hscope + | some (.rLess, e), _, hscope => simp [Cst.VariableDef.toPRScope?] at hscope + | some (.rLessEq, e), _, hscope => simp [Cst.VariableDef.toPRScope?] at hscope + | some (.rGreater, e), _, hscope => simp [Cst.VariableDef.toPRScope?] at hscope + | some (.rGreaterEq, e), _, hscope => simp [Cst.VariableDef.toPRScope?] at hscope + | some (.rNotEq, e), _, hscope => simp [Cst.VariableDef.toPRScope?] at hscope + +/-- Per-condition agreement: a condition's `foldAnd` leaf equals its AST + `Condition.toExpr`. -/ +theorem cond_leaf_eq {c : Cst.Cond} {cond : Condition} {leaf : Expr} : + c.toCondition? = some cond → (Cst.Cond.toExpr c).toAExpr? = some leaf → + leaf = Condition.toExpr cond := by + intro hcond hleaf + obtain ⟨ccond, cexpr⟩ := c + cases ccond <;> cases cexpr <;> + simp_all [Cst.Cond.toCondition?, Cst.Ident.toConditionKind?, Cst.Cond.toExpr, + Condition.toExpr, Option.bind_eq_some_iff] + all_goals first + | (subst hcond; simp []) + | (obtain ⟨a, ha, rfl⟩ := hcond + rw [cond_not_toAExpr ha] at hleaf + simp only [Option.some.injEq] at hleaf + simp [← hleaf]) + +/-- Condition leaves agree: the `foldAnd` condition leaves equal the AST policy's + condition expressions. -/ +theorem cond_leaves_eq (conds : List Cst.Cond) (condLeaves : List Expr) (apConds : Conditions) : + (conds.map Cst.Cond.toExpr).mapM Cst.Expr.toAExpr? = some condLeaves → + conds.mapM Cst.Cond.toCondition? = some apConds → + condLeaves = apConds.map Condition.toExpr := by + induction conds generalizing condLeaves apConds with + | nil => intro h1 h2; simp_all [List.mapM_nil] + | cons c cs ih => + intro h1 h2 + rw [List.map_cons, List.mapM_cons] at h1 + rw [List.mapM_cons] at h2 + simp [Option.bind_eq_some_iff] at h1 h2 + obtain ⟨l0, hl0, lrest, hlrest, hcl⟩ := h1 + obtain ⟨cond0, hcond0, condrest, hcondrest, hap⟩ := h2 + rw [← List.mapM_map] at hlrest + have hper := cond_leaf_eq hcond0 hl0 + have hrest := ih lrest condrest hlrest hcondrest + subst hcl; subst hap; subst hper; subst hrest; rfl + +/- ===== Full-`Except`-equality analogs (for `policy_to_expr_sound`) ===== -/ + +/-- Full-equality congruence for `.and`: `evaluate (a.and x)` is determined + pointwise by `evaluate a` and `evaluate x`. -/ +theorem and_eval_congr {a a' x x' : Expr} {req : Request} {es : Entities} + (ha : evaluate a req es = evaluate a' req es) + (hx : evaluate x req es = evaluate x' req es) : + evaluate (a.and x) req es = evaluate (a'.and x') req es := by + rw [evaluate_and_eq, evaluate_and_eq, ha, hx] + +/-- Full-equality congruence for `bigAnd`. -/ +theorem bigAnd_eval_congr {a a' : Expr} {l l' : List Expr} {req : Request} {es : Entities} + (ha : evaluate a req es = evaluate a' req es) + (h : List.Forall₂ (fun e e' => evaluate e req es = evaluate e' req es) l l') : + evaluate (bigAnd a l) req es = evaluate (bigAnd a' l') req es := by + induction h generalizing a a' with + | nil => simpa [bigAnd] using ha + | cons hr _ ih => + simp only [bigAnd, List.foldl_cons] + exact ih (and_eval_congr ha hr) + +/-- Reflexive `Forall₂` of evaluation-equality. -/ +theorem forall₂_eval_refl (l : List Expr) (req : Request) (es : Entities) : + List.Forall₂ (fun e e' => evaluate e req es = evaluate e' req es) l l := by + induction l with + | nil => exact List.Forall₂.nil + | cons _ _ ih => exact List.Forall₂.cons rfl ih + +/-- Membership against a singleton set equals membership against the bare + literal (action-scope `in uid`), as a full evaluation equality. -/ +theorem evaluate_mem_singleton_eq (v : Var) (uid : EntityUID) (req : Request) (es : Entities) : + evaluate (.binaryApp .mem (.var v) (.set [.lit (.entityUID uid)])) req es = + evaluate (.binaryApp .mem (.var v) (.lit (.entityUID uid))) req es := by + have hels : (Set.make [Value.prim (Prim.entityUID uid)]).elts = [Value.prim (Prim.entityUID uid)] := by + simp [Set.make, Set.elts, List.canonicalize_singleton] + have key : ∀ val1 : Value, + apply₂ .mem val1 (.set (Set.make [.prim (.entityUID uid)])) es + = apply₂ .mem val1 (.prim (.entityUID uid)) es := by + intro val1 + cases val1 with + | prim p => + cases p with + | entityUID a => + have huids : (Set.make [uid]).elts = [uid] := by + simp [Set.make, Set.elts, List.canonicalize_singleton] + simp only [apply₂, inₛ, Set.mapOrErr, hels, List.mapM_cons, List.mapM_nil, + Value.asEntityUID, bind, Except.bind, pure, Except.pure, Set.any, huids, List.any, + Bool.or_false] + | _ => simp [apply₂] + | _ => simp [apply₂] + simp only [evaluate, List.mapM₁_eq_mapM (fun e => evaluate e req es), List.mapM_cons, + List.mapM_nil, bind, Except.bind, pure, Except.pure, key] + +/-- Principal-scope leaf: the `foldAnd` leaf equals `ps.toExpr` on evaluation. -/ +theorem principal_leaf_eq {vp : Cst.VariableDef} {ps : PrincipalScope} {leaf : Expr} + (req : Request) (es : Entities) : + vp.toPrincipalScope? = some ps → + vp.toExpr.toAExpr? = some leaf → + evaluate leaf req es = evaluate ps.toExpr req es := by + intro hps hleaf + simp only [Cst.VariableDef.toPrincipalScope?] at hps + split at hps <;> [skip; simp at hps] + rename_i hvar + simp [Option.bind_eq_some_iff] at hps + obtain ⟨scope, hscope, hps⟩ := hps + subst hps + have hv : (vp.var.varToAddExpr).toExprOrSpecial? = some (Cst.ExprOrSpecial.var .principal) := by + rw [hvar]; open Cst in simp [Ident.varToAddExpr, Primary.toMember, Member.toUnary, + Unary.toMultExpr, MultExpr.toAddExpr, AddExpr.toExprOrSpecial?, + MultExpr.toExprOrSpecial?, Unary.toExprOrSpecial?, Member.toExprOrSpecial?, + Primary.toExprOrSpecial?, Name.toVar?, memberAuxA, memberAux] + rw [toPRScope_leaf hv hscope hleaf]; rfl + +/-- Resource-scope leaf: the `foldAnd` leaf equals `rs.toExpr` on evaluation. -/ +theorem resource_leaf_eq {vr : Cst.VariableDef} {rs : ResourceScope} {leaf : Expr} + (req : Request) (es : Entities) : + vr.toResourceScope? = some rs → + vr.toExpr.toAExpr? = some leaf → + evaluate leaf req es = evaluate rs.toExpr req es := by + intro hrs hleaf + simp only [Cst.VariableDef.toResourceScope?] at hrs + split at hrs <;> [skip; simp at hrs] + rename_i hvar + simp [Option.bind_eq_some_iff] at hrs + obtain ⟨scope, hscope, hrs⟩ := hrs + subst hrs + have hv : (vr.var.varToAddExpr).toExprOrSpecial? = some (Cst.ExprOrSpecial.var .resource) := by + rw [hvar]; open Cst in simp [Ident.varToAddExpr, Primary.toMember, Member.toUnary, + Unary.toMultExpr, Cst.MultExpr.toAddExpr, AddExpr.toExprOrSpecial?, + MultExpr.toExprOrSpecial?, Unary.toExprOrSpecial?, Member.toExprOrSpecial?, + Primary.toExprOrSpecial?, Name.toVar?, memberAuxA, memberAux] + rw [toPRScope_leaf hv hscope hleaf]; rfl + +/-- Action-scope leaf: the `foldAnd` leaf equals `as.toExpr` on evaluation + (single-entity `in` case bridged by `evaluate_mem_singleton_eq`). -/ +theorem action_leaf_eq {va : Cst.VariableDef} {as : ActionScope} {leaf : Expr} + (req : Request) (es : Entities) : + va.toActionScope? = some as → + va.toExpr.toAExpr? = some leaf → + evaluate leaf req es = evaluate as.toExpr req es := by + intro has hleaf + have collapse : ∀ r : Cst.Relation, + ({initial := r, extended := []} : Cst.AndExpr).toOrExpr.toExpr.toAExpr? = r.toAExpr? := by + intro r + simp [Cst.AndExpr.toOrExpr, Cst.OrExpr.toExpr, Cst.Expr.toAExpr?, Cst.Expr.toExprOrSpecial?, + Cst.ExprImpl.toExprOrSpecial?, Cst.ExprData.toExprOrSpecial?, Cst.OrExpr.toExprOrSpecial?, + Cst.AndExpr.toExprOrSpecial?, Cst.Relation.toAExpr?] + obtain ⟨var, et, ineq⟩ := va + simp only [Cst.VariableDef.toExpr, Cst.VariableDef.toAndExpr] at hleaf + cases var + case idAction => + have hv : (Cst.Ident.idAction.varToAddExpr).toExprOrSpecial? = some (Cst.ExprOrSpecial.var .action) := by + open Cst in simp [Ident.varToAddExpr, Primary.toMember, Member.toUnary, Unary.toMultExpr, + MultExpr.toAddExpr, AddExpr.toExprOrSpecial?, MultExpr.toExprOrSpecial?, + Unary.toExprOrSpecial?, Member.toExprOrSpecial?, Primary.toExprOrSpecial?, + Cst.Name.toVar?, memberAuxA, memberAux] + have hv2 : (Cst.Ident.idAction.varToAddExpr).toAExpr? = some (Expr.var .action) := by + simp [Cst.AddExpr.toAExpr?, hv, Cst.ExprOrSpecial.toExpr?] + cases et + case some t => + simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?] at has + case none => + cases ineq with + | none => + open Cst in simp [VariableDef.toActionScope?, VariableDef.toActionScopeAux?, + containsOnlyActionTypes?] at has + subst has + rw [collapse] at hleaf + open Cst in simp [Relation.tt, Primary.toMember, Member.toUnary, Unary.toMultExpr, + MultExpr.toAddExpr, AddExpr.toRelation, Relation.toAExpr?, + Relation.toExprOrSpecial?, AddExpr.toExprOrSpecial?, MultExpr.toExprOrSpecial?, + Unary.toExprOrSpecial?, Member.toExprOrSpecial?, Primary.toExprOrSpecial?, + Literal.toExprOrSpecial?, memberAuxA, memberAux, ExprOrSpecial.toExpr?] at hleaf + rw [← hleaf]; rfl + | some opE => + obtain ⟨op, e⟩ := opE + cases op with + | rEq => + cases huid : e.toEntityUID? with + | none => simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?, huid] at has + | some uid => + simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?, huid, + ] at has + obtain ⟨hcheck, hsc⟩ := has + subst hsc + rw [collapse] at hleaf + open Cst in simp [Relation.toAExpr?, Relation.toExprOrSpecial?, hv, constructExprRel, + toAddExpr_toAExpr, toEntityUID_toAExpr huid, ExprOrSpecial.toExpr?, + ] at hleaf + rw [← hleaf]; rfl + | rIn => + cases hr : e.toMultipleEntityUID? with + | none => simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?, + Cst.Expr.toEntityUIDs?, hr] at has + | some r => + have hmem := expr_mem_toAExpr hr + have hleaf' : leaf = Expr.binaryApp .mem (.var .action) (memToExpr r) := by + rw [collapse] at hleaf + open Cst in simp [Cst.Relation.toAExpr?, Cst.Relation.toExprOrSpecial?, hv, Cst.constructExprRel, + toAddExpr_toAExpr, hmem, Cst.ExprOrSpecial.toExpr?] at hleaf + rw [← hleaf] + cases r with + | inl uid => + simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?, + Cst.Expr.toEntityUIDs?, hr] at has + obtain ⟨hcheck, hsc⟩ := has + subst hsc + subst hleaf' + simp only [memToExpr, ActionScope.toExpr, List.map_cons, List.map_nil] + exact (evaluate_mem_singleton_eq _ uid req es).symm + | inr uids => + simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?, + Cst.Expr.toEntityUIDs?, hr] at has + obtain ⟨hcheck, hsc⟩ := has + subst hsc + subst hleaf' + simp only [memToExpr, ActionScope.toExpr] + | rLess => simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?] at has + | rLessEq => simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?] at has + | rGreater => simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?] at has + | rGreaterEq => simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?] at has + | rNotEq => simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?] at has + all_goals simp [Cst.VariableDef.toActionScope?, Cst.VariableDef.toActionScopeAux?] at has + +/-- **Full `Except`-equality policy bridge.** When a CST policy translates to an + AST policy, the CST policy's expression translation evaluates identically + (errors included) to the AST policy's expression. This is the policy-level + analog of `expr_to_expr_sound`, strengthening `policy_to_expr_agrees` from an + `ok`-iff to a full equality. -/ +theorem policy_to_expr_sound (cp : Cst.Policy) (ap : Policy) + (ce : Cst.Expr) (ae : Expr) (req : Request) (es : Entities) : + cp.toPolicy? = some ap → + cp.toExpr = ce → + ce.toAExpr? = some ae → + evaluate ae req es = evaluate ap.toExpr req es := by + intro hap hce hae + obtain ⟨⟨pid, annots, eff, vars, conds⟩⟩ := cp + rw [← hce] at hae + simp only [Cst.Policy.toExpr, Cst.PolicyImpl.toExpr] at hae + simp only [Cst.Policy.toPolicy?, Cst.PolicyImpl.toPolicy?, bind, Option.bind_eq_some_iff, + Option.some.injEq] at hap + obtain ⟨eff', heff, ⟨ps, acts, rs⟩, hsc, apConds, hconds, hapeq⟩ := hap + subst hapeq + match vars, hsc, hae with + | [vp, va, vr], hscope, hae => + simp only [Cst.extractScope?, bind, Option.bind_eq_some_iff] at hscope + obtain ⟨ps', hps, as', has, rs', hrs, rfl, rfl, rfl⟩ := hscope + obtain ⟨leaves, hmapM, haeForm⟩ := foldAnd_inv _ ae hae + rw [List.map_cons, List.map_cons, List.map_cons, List.map_nil, List.cons_append, + List.cons_append, List.cons_append, List.nil_append, List.mapM_cons] at hmapM + simp only [bind, Option.bind_eq_some_iff, Option.pure_def, Option.some.injEq] at hmapM + obtain ⟨Lp, hLp, rest1, hrest1, e1⟩ := hmapM + rw [List.mapM_cons] at hrest1; simp only [bind, Option.bind_eq_some_iff, Option.pure_def, Option.some.injEq] at hrest1 + obtain ⟨La, hLa, rest2, hrest2, e2⟩ := hrest1 + rw [List.mapM_cons] at hrest2; simp only [bind, Option.bind_eq_some_iff, Option.pure_def, Option.some.injEq] at hrest2 + obtain ⟨Lr, hLr, condLeaves, hcond, e3⟩ := hrest2 + subst e1; subst e2; subst e3 + have hcondeq : condLeaves = apConds.map Condition.toExpr := + cond_leaves_eq conds condLeaves apConds hcond (by simpa [Cst.toConditions?] using hconds) + subst haeForm + rw [evaluate_policy_toExpr] + apply bigAnd_eval_congr + · exact principal_leaf_eq req es hps hLp + · refine List.Forall₂.cons (action_leaf_eq req es has hLa) ?_ + refine List.Forall₂.cons (resource_leaf_eq req es hrs hLr) ?_ + rw [hcondeq]; exact forall₂_eval_refl _ req es + | [], hscope, _ => simp [Cst.extractScope?] at hscope + | [_], hscope, _ => simp [Cst.extractScope?] at hscope + | [_, _], hscope, _ => simp [Cst.extractScope?] at hscope + | _ :: _ :: _ :: _ :: _, hscope, _ => simp [Cst.extractScope?] at hscope diff --git a/cedar-lean/CedarFFI/ToJson.lean b/cedar-lean/CedarFFI/ToJson.lean index be43bf8bc..b492cc849 100644 --- a/cedar-lean/CedarFFI/ToJson.lean +++ b/cedar-lean/CedarFFI/ToJson.lean @@ -209,6 +209,7 @@ deriving instance Lean.ToJson for Residual deriving instance Lean.ToJson for Effect deriving instance Lean.ToJson for TPE.ResidualPolicy deriving instance Lean.ToJson for TPE.Response +deriving instance Lean.ToJson for Spec.CstError deriving instance Lean.ToJson for Spec.Error diff --git a/cedar-lean/UnitTest/Main.lean b/cedar-lean/UnitTest/Main.lean index 9b36283a8..295c0aed5 100644 --- a/cedar-lean/UnitTest/Main.lean +++ b/cedar-lean/UnitTest/Main.lean @@ -18,6 +18,9 @@ import UnitTest.CedarProto import UnitTest.Datetime import UnitTest.Decimal import UnitTest.IPAddr +import UnitTest.Parser +import UnitTest.ParserStrings +import UnitTest.ParserStress import UnitTest.Proto import UnitTest.Wildcard import UnitTest.TPE @@ -29,6 +32,9 @@ def tests := Datetime.tests ++ Decimal.tests ++ IPAddr.tests ++ + Parser.tests ++ + ParserStrings.tests ++ + ParserStress.tests ++ Wildcard.tests ++ Proto.tests ++ CedarProto.tests ++ diff --git a/cedar-lean/UnitTest/Parser.lean b/cedar-lean/UnitTest/Parser.lean new file mode 100644 index 000000000..bea4cb84e --- /dev/null +++ b/cedar-lean/UnitTest/Parser.lean @@ -0,0 +1,313 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +import Cedar.Frontend.Parser +import UnitTest.Run + +/-! This file defines unit tests for the Cedar policy parser. -/ + +namespace UnitTest.Parser + +open UnitTest Cedar.Frontend.Cst Cedar.Frontend.Cst.Parser + +private def testParseOk (name : String) (input : String) (numPolicies : Nat) : TestCase IO := + test name ⟨fun _ => match parse input with + | .ok ps => checkEq ps.ps.length numPolicies + | .error e => pure (.error s!"parse failed: {e}")⟩ + +private def testParseFail (name : String) (input : String) : TestCase IO := + test name ⟨fun _ => checkEq (parse input).isOk false⟩ + +private def testParseFileOk (name : String) (path : String) (numPolicies : Nat) : TestCase IO := + test name ⟨fun _ => do + let input ← IO.FS.readFile path + match parse input with + | .ok ps => checkEq ps.ps.length numPolicies + | .error e => pure (.error s!"parse failed: {e}")⟩ + +private def testParseFail' (name : String) (path : String) : TestCase IO := + test s!"neg: {name}" ⟨fun _ => do + let input ← IO.FS.readFile path + checkEq (parse input).isOk false⟩ + +def testsForBasicPolicies := + suite "Parser.BasicPolicies" + [ + testParseOk "minimal permit" + "permit(principal, action, resource);" 1, + testParseOk "minimal forbid" + "forbid(principal, action, resource);" 1, + testParseOk "multiple policies" + "permit(principal, action, resource); forbid(principal, action, resource);" 2, + testParseOk "with line comments" + "// comment\npermit(principal, action, resource);" 1, + testParseFail "missing semicolon" + "permit(principal, action, resource)", + testParseFail "missing closing paren" + "permit(principal, action, resource;", + testParseOk "empty input" + "" 0 + ] + +def testsForScopes := + suite "Parser.Scopes" + [ + testParseOk "principal ==" + "permit(principal == User::\"alice\", action, resource);" 1, + testParseOk "principal in" + "permit(principal in Group::\"admins\", action, resource);" 1, + testParseOk "principal is" + "permit(principal is User, action, resource);" 1, + testParseOk "principal is in" + "permit(principal is User in Group::\"admins\", action, resource);" 1, + testParseOk "action ==" + "permit(principal, action == Action::\"read\", resource);" 1, + testParseOk "action in list" + "permit(principal, action in [Action::\"read\", Action::\"write\"], resource);" 1, + testParseOk "resource ==" + "permit(principal, action, resource == File::\"x\");" 1, + testParseOk "resource in" + "permit(principal, action, resource in Folder::\"docs\");" 1, + testParseOk "all constrained" + "forbid(principal == User::\"x\", action == Action::\"y\", resource in Folder::\"z\");" 1 + ] + +def testsForConditions := + suite "Parser.Conditions" + [ + testParseOk "when" + "permit(principal, action, resource) when { true };" 1, + testParseOk "unless" + "forbid(principal, action, resource) unless { false };" 1, + testParseOk "when + unless" + "permit(principal, action, resource) when { true } unless { false };" 1, + testParseOk "multiple when" + "permit(principal, action, resource) when { true } when { true };" 1 + ] + +def testsForExpressions := + suite "Parser.Expressions" + [ + testParseOk "if-then-else" + "permit(principal, action, resource) when { if true then 1 else 2 };" 1, + testParseOk "nested if-then-else" + "permit(principal, action, resource) when { if true then if false then 1 else 2 else 3 };" 1, + testParseOk "or" + "permit(principal, action, resource) when { true || false };" 1, + testParseOk "chained or" + "permit(principal, action, resource) when { true || false || true };" 1, + testParseOk "and" + "permit(principal, action, resource) when { true && false };" 1, + testParseOk "chained and" + "permit(principal, action, resource) when { true && false && true };" 1, + testParseOk "or and precedence" + "permit(principal, action, resource) when { true || false && true };" 1, + testParseOk "not" + "permit(principal, action, resource) when { !true };" 1, + testParseOk "double not" + "permit(principal, action, resource) when { !!true };" 1, + testParseOk "numeric negation" + "permit(principal, action, resource) when { -context.x };" 1 + ] + +def testsForArithmetic := + suite "Parser.Arithmetic" + [ + testParseOk "addition" + "permit(principal, action, resource) when { 1 + 2 };" 1, + testParseOk "subtraction" + "permit(principal, action, resource) when { 5 - 3 };" 1, + testParseOk "multiplication" + "permit(principal, action, resource) when { 2 * 3 };" 1, + testParseOk "division" + "permit(principal, action, resource) when { 10 / 2 };" 1, + testParseOk "modulo" + "permit(principal, action, resource) when { 10 % 3 };" 1, + testParseOk "chained add/sub" + "permit(principal, action, resource) when { 1 + 2 - 3 + 4 };" 1, + testParseOk "chained mul/div/mod" + "permit(principal, action, resource) when { 2 * 3 / 4 % 5 };" 1, + testParseOk "precedence" + "permit(principal, action, resource) when { 1 + 2 * 3 };" 1, + testParseOk "parens override precedence" + "permit(principal, action, resource) when { (1 + 2) * 3 };" 1 + ] + +def testsForComparisons := + suite "Parser.Comparisons" + [ + testParseOk "less" + "permit(principal, action, resource) when { context.x < 10 };" 1, + testParseOk "lessEq" + "permit(principal, action, resource) when { context.x <= 10 };" 1, + testParseOk "greater" + "permit(principal, action, resource) when { context.x > 0 };" 1, + testParseOk "greaterEq" + "permit(principal, action, resource) when { context.x >= 1 };" 1, + testParseOk "eq" + "permit(principal, action, resource) when { context.x == 1 };" 1, + testParseOk "neq" + "permit(principal, action, resource) when { context.x != 0 };" 1 + ] + +def testsForRelations := + suite "Parser.Relations" + [ + testParseOk "in" + "permit(principal, action, resource) when { principal in Group::\"x\" };" 1, + testParseOk "has" + "permit(principal, action, resource) when { resource has owner };" 1, + testParseOk "like" + "permit(principal, action, resource) when { resource.name like \"*.txt\" };" 1, + testParseOk "is" + "permit(principal, action, resource) when { resource is Folder };" 1, + testParseOk "is in" + "permit(principal, action, resource) when { resource is Folder in Folder::\"root\" };" 1 + ] + +def testsForMemberAccess := + suite "Parser.MemberAccess" + [ + testParseOk "field" + "permit(principal, action, resource) when { resource.owner };" 1, + testParseOk "chained fields" + "permit(principal, action, resource) when { context.a.b.c };" 1, + testParseOk "index" + "permit(principal, action, resource) when { resource.tags[\"env\"] };" 1, + testParseOk "call no args" + "permit(principal, action, resource) when { resource.tags.size() };" 1, + testParseOk "call one arg" + "permit(principal, action, resource) when { [1,2].contains(1) };" 1, + testParseOk "call multiple args" + "permit(principal, action, resource) when { context.x.foo(1, 2, 3) };" 1, + testParseOk "mixed access" + "permit(principal, action, resource) when { resource.tags[\"x\"].size() };" 1 + ] + +def testsForPrimary := + suite "Parser.Primary" + [ + testParseOk "true" + "permit(principal, action, resource) when { true };" 1, + testParseOk "false" + "permit(principal, action, resource) when { false };" 1, + testParseOk "number" + "permit(principal, action, resource) when { 42 };" 1, + testParseOk "string" + "permit(principal, action, resource) when { \"hello\" };" 1, + testParseOk "string escapes" + "permit(principal, action, resource) when { \"a\\nb\\tc\\\\d\\\"e\" };" 1, + testParseOk "entity ref" + "permit(principal, action, resource) when { User::\"alice\" };" 1, + testParseOk "namespaced entity ref" + "permit(principal, action, resource) when { App::User::\"alice\" };" 1, + testParseOk "empty list" + "permit(principal, action, resource) when { [] };" 1, + testParseOk "list" + "permit(principal, action, resource) when { [1, 2, 3] };" 1, + testParseOk "empty record" + "permit(principal, action, resource) when { {} };" 1, + testParseOk "record" + "permit(principal, action, resource) when { {\"a\": 1, \"b\": true} };" 1, + testParseOk "slot ?principal" + "permit(principal == ?principal, action, resource);" 1, + testParseOk "slot ?resource" + "permit(principal, action, resource in ?resource);" 1, + testParseOk "parenthesized" + "permit(principal, action, resource) when { (1 + 2) };" 1, + testParseOk "variables" + "permit(principal, action, resource) when { principal == resource };" 1 + ] + +def testsForFiles := + suite "Parser.Files" + [ + testParseFileOk "comprehensive.cedar" + "UnitTest/parser_tests/comprehensive.cedar" 100, + testParseFileOk "comments.cedar" + "UnitTest/parser_tests/comments.cedar" 21, + -- Syntactic errors that the parser must reject + testParseFail' "missing_semicolon" "UnitTest/parser_tests/negative/missing_semicolon.cedar", + testParseFail' "missing_close_paren" "UnitTest/parser_tests/negative/missing_close_paren.cedar", + testParseFail' "missing_open_paren" "UnitTest/parser_tests/negative/missing_open_paren.cedar", + testParseFail' "no_effect" "UnitTest/parser_tests/negative/no_effect.cedar", + testParseFail' "double_effect" "UnitTest/parser_tests/negative/double_effect.cedar", + testParseFail' "missing_when_brace" "UnitTest/parser_tests/negative/missing_when_brace.cedar", + testParseFail' "unclosed_when_brace" "UnitTest/parser_tests/negative/unclosed_when_brace.cedar", + testParseFail' "unclosed_string" "UnitTest/parser_tests/negative/unclosed_string.cedar", + testParseFail' "annotation_after_effect" "UnitTest/parser_tests/negative/annotation_after_effect.cedar", + testParseFail' "double_semicolon" "UnitTest/parser_tests/negative/double_semicolon.cedar", + testParseFail' "condition_without_braces" "UnitTest/parser_tests/negative/condition_without_braces.cedar", + testParseFail' "invalid_entity_ref" "UnitTest/parser_tests/negative/invalid_entity_ref.cedar", + testParseFail' "unclosed_list" "UnitTest/parser_tests/negative/unclosed_list.cedar", + testParseFail' "unclosed_record" "UnitTest/parser_tests/negative/unclosed_record.cedar", + testParseFail' "invalid_annotation_placement" "UnitTest/parser_tests/negative/invalid_annotation_placement.cedar", + testParseFail' "missing_condition_keyword" "UnitTest/parser_tests/negative/missing_condition_keyword.cedar", + testParseFail' "pipe_instead_of_or" "UnitTest/parser_tests/negative/pipe_instead_of_or.cedar", + testParseFail' "ampersand_instead_of_and" "UnitTest/parser_tests/negative/ampersand_instead_of_and.cedar", + testParseFail' "like_without_pattern" "UnitTest/parser_tests/negative/like_without_pattern.cedar", + testParseFail' "unclosed_paren_expr" "UnitTest/parser_tests/negative/unclosed_paren_expr.cedar", + testParseFail' "empty_when_body" "UnitTest/parser_tests/negative/empty_when_body.cedar", + testParseFail' "missing_eid_in_ref" "UnitTest/parser_tests/negative/missing_eid_in_ref.cedar", + testParseFail' "dot_without_field" "UnitTest/parser_tests/negative/dot_without_field.cedar", + testParseFail' "eq_instead_of_double_eq" "UnitTest/parser_tests/negative/eq_instead_of_double_eq.cedar", + testParseFail' "number_as_entity_type" "UnitTest/parser_tests/negative/number_as_entity_type.cedar", + -- Semantic errors that Cedar rejects at parse time (our CST parser is more permissive) + -- These are tested to document the difference; our parser accepts them at CST level + testParseFileOk "neg/invalid_effect (semantic)" + "UnitTest/parser_tests/negative/invalid_effect.cedar" 1, + testParseFileOk "neg/missing_action (semantic)" + "UnitTest/parser_tests/negative/missing_action.cedar" 1, + testParseFileOk "neg/missing_resource (semantic)" + "UnitTest/parser_tests/negative/missing_resource.cedar" 1, + testParseFileOk "neg/missing_principal (semantic)" + "UnitTest/parser_tests/negative/missing_principal.cedar" 1, + testParseFileOk "neg/invalid_operator_div (semantic)" + "UnitTest/parser_tests/negative/invalid_operator_div.cedar" 1, + testParseFileOk "neg/invalid_operator_mod (semantic)" + "UnitTest/parser_tests/negative/invalid_operator_mod.cedar" 1, + testParseFileOk "neg/reserved_word_cedar (semantic)" + "UnitTest/parser_tests/negative/reserved_word_cedar.cedar" 1, + testParseFileOk "neg/invalid_slot_name (semantic)" + "UnitTest/parser_tests/negative/invalid_slot_name.cedar" 1, + testParseFileOk "neg/slot_in_condition (semantic)" + "UnitTest/parser_tests/negative/slot_in_condition.cedar" 1, + testParseFileOk "neg/empty_scope (semantic)" + "UnitTest/parser_tests/negative/empty_scope.cedar" 1, + testParseFileOk "neg/extra_scope_element (semantic)" + "UnitTest/parser_tests/negative/extra_scope_element.cedar" 1, + testParseFileOk "neg/invalid_has_number (semantic)" + "UnitTest/parser_tests/negative/invalid_has_number.cedar" 1, + testParseFileOk "neg/is_with_string (semantic)" + "UnitTest/parser_tests/negative/is_with_string.cedar" 1, + testParseFileOk "neg/invalid_method_syntax (semantic)" + "UnitTest/parser_tests/negative/invalid_method_syntax.cedar" 1, + testParseFail' "invalid_relop_single_eq" "UnitTest/parser_tests/negative/invalid_relop_single_eq.cedar" + ] + +def tests : List (TestSuite IO) := + [testsForBasicPolicies, + testsForScopes, + testsForConditions, + testsForExpressions, + testsForArithmetic, + testsForComparisons, + testsForRelations, + testsForMemberAccess, + testsForPrimary, + testsForFiles] + +end UnitTest.Parser diff --git a/cedar-lean/UnitTest/ParserStress.lean b/cedar-lean/UnitTest/ParserStress.lean new file mode 100644 index 000000000..963b995ac --- /dev/null +++ b/cedar-lean/UnitTest/ParserStress.lean @@ -0,0 +1,84 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +import Cedar.Frontend.Parser +import UnitTest.Run + +/-! This file defines stress tests for parsing large policies and expressions. -/ + +namespace UnitTest.ParserStress + +open UnitTest Cedar.Frontend.Cst.Parser + +private def testParseFileOk (name : String) (path : String) (numPolicies : Nat) : TestCase IO := + test name ⟨fun _ => do + let input ← IO.FS.readFile path + match parse input with + | .ok ps => checkEq ps.ps.length numPolicies + | .error e => pure (.error s!"parse failed: {e}")⟩ + +private def testParseOk (name : String) (input : String) (numPolicies : Nat) : TestCase IO := + test name ⟨fun _ => match parse input with + | .ok ps => checkEq ps.ps.length numPolicies + | .error e => pure (.error s!"parse failed: {e}")⟩ + +def testsForStressFile := + suite "ParserStress.File" + [ + testParseFileOk "stress.cedar" + "UnitTest/parser_tests/stress.cedar" 20 + ] + +def testsForLargeExpressions := + suite "ParserStress.LargeExpressions" + [ + testParseOk "50-element set" + ("permit(principal, action, resource) when { [" ++ + String.intercalate ", " (List.range 50 |>.map toString) ++ + "].contains(context.x) };") 1, + testParseOk "30-field record" + ("permit(principal, action, resource) when { {" ++ + String.intercalate ", " (List.range 30 |>.map fun i => s!"f{i}: {i}") ++ + "} == context.x };") 1, + testParseOk "30-element action list" + ("permit(principal, action in [" ++ + String.intercalate ", " (List.range 30 |>.map fun i => s!"Action::\"{i}\"") ++ + "], resource);") 1, + testParseOk "30-deep member access" + ("permit(principal, action, resource) when { context" ++ + String.join (List.replicate 30 ".x") ++ + " == \"deep\" };") 1, + testParseOk "20-deep nested parens" + ("permit(principal, action, resource) when { " ++ + String.join (List.replicate 20 "(") ++ + "context.x" ++ + String.join (List.replicate 20 ")") ++ + " == 1 };") 1, + testParseOk "15 when/unless clauses" + ("permit(principal, action, resource)" ++ + String.join (List.range 10 |>.map fun _ => " when { true }") ++ + String.join (List.range 5 |>.map fun _ => " unless { false }") ++ + ";") 1, + testParseOk "20 annotations" + (String.join (List.range 20 |>.map fun i => s!"@a{i}(\"v{i}\")\n") ++ + "permit(principal, action, resource);") 1 + ] + +def tests : List (TestSuite IO) := + [testsForStressFile, + testsForLargeExpressions] + +end UnitTest.ParserStress diff --git a/cedar-lean/UnitTest/ParserStrings.lean b/cedar-lean/UnitTest/ParserStrings.lean new file mode 100644 index 000000000..b976f8ffc --- /dev/null +++ b/cedar-lean/UnitTest/ParserStrings.lean @@ -0,0 +1,217 @@ +/- + Copyright Cedar Contributors + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + https://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. +-/ + +import Cedar.Frontend.Parser +import UnitTest.Run + +/-! This file defines unit tests for parsing strings, entity UIDs, and identifiers. -/ + +namespace UnitTest.ParserStrings + +open UnitTest Cedar.Frontend.Cst Cedar.Frontend.Cst.Parser + +private def testParseOk (name : String) (input : String) (numPolicies : Nat) : TestCase IO := + test name ⟨fun _ => match parse input with + | .ok ps => checkEq ps.ps.length numPolicies + | .error e => pure (.error s!"parse failed: {e}")⟩ + +private def testParseFail (name : String) (input : String) : TestCase IO := + test name ⟨fun _ => checkEq (parse input).isOk false⟩ + +private def testParseFileOk (name : String) (path : String) (numPolicies : Nat) : TestCase IO := + test name ⟨fun _ => do + let input ← IO.FS.readFile path + match parse input with + | .ok ps => checkEq ps.ps.length numPolicies + | .error e => pure (.error s!"parse failed: {e}")⟩ + +/-- Parse a single expression wrapped in a policy -/ +private def parseExpr (input : String) : Except String Expr := + let policy := "permit(principal, action, resource) when { " ++ input ++ " };" + match parse policy with + | .ok ps => match ps.ps with + | [.policy p] => match p.conds with + | [c] => .ok c.body + | _ => .error "expected one condition" + | _ => .error "expected one policy" + | .error e => .error e + +/-- Extract string literal value from a parsed expression -/ +private def getStringLit (input : String) : Except String String := do + let e ← parseExpr input + let .expr impl := e + let .edOr orE := impl.expr | .error "not edOr" + if !orE.extended.isEmpty then .error "has or-extensions" + let andE := orE.initial + if !andE.extended.isEmpty then .error "has and-extensions" + match andE.initial with + | .rCommon addE _ => + if !addE.extended.isEmpty then .error "has add-extensions" + let multE := addE.initial + if !multE.extended.isEmpty then .error "has mult-extensions" + let unaryE := multE.initial + if unaryE.op.isSome then .error "has unary op" + let memberE := unaryE.item + if !memberE.access.isEmpty then .error "has member access" + match memberE.item with + | .literal (.liStr s) => .ok s + | _ => .error "not a string literal" + | _ => .error "not rCommon" + +/-- Extract EUID path and eid from `permit(principal == Type::"eid", ...)` -/ +private def getEUID (input : String) : Except String (List String × String) := do + let ps ← parse input + match ps.ps with + | [.policy p] => + match p.vars with + | varDef :: _ => + match varDef.ineq with + | some (_, eqExpr) => + let .expr impl := eqExpr + let .edOr orE := impl.expr | .error "not edOr" + match orE.initial.initial with + | .rCommon addE _ => + match addE.initial.initial.item.item with + | .ref (.uid name (.string eid)) => + let path := (name.path ++ [name.name]).map Ident.toString + .ok (path, eid) + | _ => .error "not a ref uid" + | _ => .error "not rCommon" + | none => .error "no == constraint" + | [] => .error "no vars" + | _ => .error "not one policy" + +/-- Extract annotation count -/ +private def getAnnotationCount (input : String) : Except String Nat := do + let ps ← parse input + match ps.ps with + | [.policy p] => .ok p.annotations.length + | _ => .error "not one policy" + +/-- Extract annotation name and value at index -/ +private def getAnnotation (input : String) (idx : Nat) : Except String (String × Option String) := do + let ps ← parse input + match ps.ps with + | [.policy p] => + match p.annotations[idx]? with + | some ann => + let name := Ident.toString ann.name + let value := ann.value.map fun (.string s) => s + .ok (name, value) + | none => .error "annotation index out of bounds" + | _ => .error "not one policy" + +-- Custom check helpers that unwrap Except + +private def checkStr (actual : Except String String) (expected : String) : IO TestResult := + match actual with + | .ok s => checkEq s expected + | .error e => pure (.error s!"extraction failed: {e}") + +private def checkEUID (actual : Except String (List String × String)) (path : List String) (eid : String) : IO TestResult := + match actual with + | .ok (p, e) => + if p == path && e == eid then pure (.ok ()) + else pure (.error s!"actual: ({p}, \"{e}\")\nexpected: ({path}, \"{eid}\")") + | .error e => pure (.error s!"extraction failed: {e}") + +private def checkAnn (actual : Except String (String × Option String)) (name : String) (value : Option String) : IO TestResult := + match actual with + | .ok (n, v) => + if n == name && v == value then pure (.ok ()) + else pure (.error s!"actual: ({n}, {v})\nexpected: ({name}, {value})") + | .error e => pure (.error s!"extraction failed: {e}") + +private def checkNat (actual : Except String Nat) (expected : Nat) : IO TestResult := + match actual with + | .ok n => checkEq n expected + | .error e => pure (.error s!"extraction failed: {e}") + +----- Test suites ----- + +def testsForStringEscapes := + suite "ParserStrings.Escapes" + [ + test "newline" ⟨fun _ => checkStr (getStringLit "\"hello\\nworld\"") "hello\nworld"⟩, + test "tab" ⟨fun _ => checkStr (getStringLit "\"tab\\there\"") "tab\there"⟩, + test "quote" ⟨fun _ => checkStr (getStringLit "\"a\\\"b\"") "a\"b"⟩, + test "backslash" ⟨fun _ => checkStr (getStringLit "\"a\\\\b\"") "a\\b"⟩, + test "null" ⟨fun _ => checkStr (getStringLit "\"a\\0b\"") (String.ofList ['a', '\x00', 'b'])⟩, + test "empty" ⟨fun _ => checkStr (getStringLit "\"\"") ""⟩, + test "spaces" ⟨fun _ => checkStr (getStringLit "\" \"") " "⟩, + test "special chars" ⟨fun _ => checkStr (getStringLit "\"!@#$%\"") "!@#$%"⟩ + ] + +def testsForEntityUIDs := + suite "ParserStrings.EntityUIDs" + [ + test "simple" ⟨fun _ => + checkEUID (getEUID "permit(principal == User::\"alice\", action, resource);") ["User"] "alice"⟩, + test "empty eid" ⟨fun _ => + checkEUID (getEUID "permit(principal == User::\"\", action, resource);") ["User"] ""⟩, + test "eid with space" ⟨fun _ => + checkEUID (getEUID "permit(principal == User::\"alice bob\", action, resource);") ["User"] "alice bob"⟩, + test "eid with escaped quote" ⟨fun _ => + checkEUID (getEUID "permit(principal == User::\"a\\\"b\", action, resource);") ["User"] "a\"b"⟩, + test "eid with backslash" ⟨fun _ => + checkEUID (getEUID "permit(principal == User::\"a\\\\b\", action, resource);") ["User"] "a\\b"⟩, + test "namespaced 2" ⟨fun _ => + checkEUID (getEUID "permit(principal == App::User::\"alice\", action, resource);") ["App", "User"] "alice"⟩, + test "namespaced 3" ⟨fun _ => + checkEUID (getEUID "permit(principal == Com::Ex::User::\"x\", action, resource);") ["Com", "Ex", "User"] "x"⟩, + test "special chars in eid" ⟨fun _ => + checkEUID (getEUID "permit(principal == User::\"user@example.com\", action, resource);") ["User"] "user@example.com"⟩, + testParseFail "missing eid" "permit(principal == User::, action, resource);", + testParseFail "number as type" "permit(principal == 123::\"alice\", action, resource);" + ] + +def testsForAnnotations := + suite "ParserStrings.Annotations" + [ + test "with value" ⟨fun _ => + checkAnn (getAnnotation "@id(\"policy1\")\npermit(principal, action, resource);" 0) "id" (some "policy1")⟩, + test "without value" ⟨fun _ => + checkAnn (getAnnotation "@shadow_mode\npermit(principal, action, resource);" 0) "shadow_mode" none⟩, + test "count 3" ⟨fun _ => + checkNat (getAnnotationCount "@a(\"1\")\n@b(\"2\")\n@c\npermit(principal, action, resource);") 3⟩, + test "second annotation" ⟨fun _ => + checkAnn (getAnnotation "@first(\"x\")\n@second(\"y\")\npermit(principal, action, resource);" 1) "second" (some "y")⟩ + ] + +def testsForIdentifiers := + suite "ParserStrings.Identifiers" + [ + testParseOk "camelCase" "permit(principal, action, resource) when { resource.camelCase == \"x\" };" 1, + testParseOk "snake_case" "permit(principal, action, resource) when { resource.snake_case == \"x\" };" 1, + testParseOk "leading underscore" "permit(principal, action, resource) when { resource._private == \"x\" };" 1, + testParseOk "single char" "permit(principal, action, resource) when { resource.x == \"x\" };" 1, + testParseOk "ALLCAPS" "permit(principal, action, resource) when { resource.ALLCAPS == \"x\" };" 1, + testParseOk "with digits" "permit(principal, action, resource) when { resource.field123 == \"x\" };" 1, + testParseOk "has with string key" "permit(principal, action, resource) when { context has \"spaces in name\" };" 1, + testParseOk "record string keys" "permit(principal, action, resource) when { {\"key with spaces\": 1} == context.x };" 1, + testParseOk "record ident keys" "permit(principal, action, resource) when { {normalKey: 1} == context.x };" 1 + ] + +def testsForFile := + suite "ParserStrings.File" + [ + testParseFileOk "strings_and_identifiers.cedar" "UnitTest/parser_tests/strings_and_identifiers.cedar" 62 + ] + +def tests : List (TestSuite IO) := + [testsForStringEscapes, testsForEntityUIDs, testsForAnnotations, testsForIdentifiers, testsForFile] + +end UnitTest.ParserStrings diff --git a/cedar-lean/UnitTest/parser_tests/comments.cedar b/cedar-lean/UnitTest/parser_tests/comments.cedar new file mode 100644 index 000000000..92d865e06 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/comments.cedar @@ -0,0 +1,93 @@ +// Comment at very start of file +permit(principal, action, resource); + +permit(principal, action, resource); // comment after semicolon + +permit(// comment inside scope +principal, action, resource); + +permit(principal,// after comma +action, resource); + +permit(principal, action, resource) +// comment between scope and condition +when { true }; + +permit(principal, action, resource) when { +// comment inside condition body +true }; + +permit(principal, action, resource) when { true } +// comment between conditions +unless { false }; + +// comment before annotation +@id("test1") +permit(principal, action, resource); + +@id("test2") // comment after annotation +permit(principal, action, resource); + +permit(principal, action, resource) when { + context.x == 1 // comment after expression + && context.y == 2 +}; + +permit(principal, action, resource) when { + context.x == 1 && + // comment between operands + context.y == 2 +}; + +permit(principal == User::"alice", // comment after entity ref +action, resource); + +permit(principal, action, resource) when { + [ + 1, // comment in list + 2, + 3 + ].contains(context.x) +}; + +permit(principal, action, resource) when { + { + key: 1, // comment in record + other: 2 + } == context.x +}; + +// Multiple consecutive comment lines +// describing this policy +// in detail +permit(principal, action, resource); + +permit(principal, action, resource) when { + if // comment after if + true + then // comment after then + 1 + else // comment after else + 2 == context.x +}; + +permit(principal, action, resource) when { + resource.tags.contains(// comment inside method args + "active") +}; + +permit(principal, action, resource) when { + principal in [ + Group::"a", // first group + Group::"b" // second group + ] +}; + +// comment with special chars: @#$%^&*(){}[] +permit(principal, action, resource); + +// comment with // nested slashes // inside +permit(principal, action, resource); + +permit(principal, action, resource) when { true }; // last policy comment +// trailing comment at end of file diff --git a/cedar-lean/UnitTest/parser_tests/comprehensive.cedar b/cedar-lean/UnitTest/parser_tests/comprehensive.cedar new file mode 100644 index 000000000..b0443bc75 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/comprehensive.cedar @@ -0,0 +1,517 @@ +// ===== Basic policy structure ===== +// policy0: minimal permit +permit (principal, action, resource); + +// policy1: minimal forbid +forbid (principal, action, resource); + +// policy2: when clause +permit (principal, action, resource) +when { true }; + +// policy3: unless clause +forbid (principal, action, resource) +unless { false }; + +// policy4: when + unless +permit (principal, action, resource) +when { true } +unless { false }; + +// policy5: multiple when clauses +permit (principal, action, resource) +when { true } +when { true }; + +// ===== Annotations ===== +// policy6: single annotation with value +@id("policy6") +permit (principal, action, resource); + +// policy7: annotation without value +@shadow_mode +forbid (principal, action, resource); + +// policy8: multiple annotations +@id("policy8") +@advice("Allow admins full access") +permit (principal, action, resource); + +// ===== Variable definitions / scope constraints ===== +// policy9: principal == +permit ( + principal == User::"alice", + action, + resource +); + +// policy10: principal in +permit ( + principal in Group::"admins", + action, + resource +); + +// policy11: principal is +permit ( + principal is User, + action, + resource +); + +// policy12: principal is ... in +permit ( + principal is User in Group::"admins", + action, + resource +); + +// policy13: action == +permit ( + principal, + action == Action::"read", + resource +); + +// policy14: action in single entity +permit ( + principal, + action in Action::"readOnly", + resource +); + +// policy15: action in list +permit ( + principal, + action in [Action::"read", Action::"write", Action::"delete"], + resource +); + +// policy16: resource == +permit ( + principal, + action, + resource == File::"report.pdf" +); + +// policy17: resource in +permit ( + principal, + action, + resource in Folder::"documents" +); + +// policy18: resource is +permit ( + principal, + action, + resource is Photo +); + +// policy19: resource is ... in +permit ( + principal, + action, + resource is Photo in Album::"vacation" +); + +// policy20: all scopes constrained +forbid ( + principal == User::"mallory", + action == Action::"admin", + resource in Folder::"secrets" +); + +// policy21: template slot ?principal +permit ( + principal == ?principal, + action, + resource +); + +// policy22: template slot ?resource +permit ( + principal, + action, + resource in ?resource +); + +// policy23: principal is with slot +permit ( + principal is User in ?principal, + action, + resource +); + +// ===== Arithmetic operators ===== +// policy24: addition +permit (principal, action, resource) +when { context.x + 1 == 10 }; + +// policy25: subtraction +permit (principal, action, resource) +when { context.x - 5 == 0 }; + +// policy26: multiplication +permit (principal, action, resource) +when { context.x * 2 == 20 }; + +// policy27: combined arithmetic with precedence +permit (principal, action, resource) +when { context.x + context.y * 2 - 1 == 10 }; + +// policy28: parenthesized arithmetic +permit (principal, action, resource) +when { (context.x + 1) * 2 == 10 }; + +// policy29: negative literal +permit (principal, action, resource) +when { context.x == -3 }; + +// policy30: negation of expression +permit (principal, action, resource) +when { -(context.x) + 10 > 0 }; + +// ===== Comparison operators ===== +// policy31: less than +permit (principal, action, resource) +when { context.level < 10 }; + +// policy32: less than or equal +permit (principal, action, resource) +when { context.level <= 10 }; + +// policy33: greater than +permit (principal, action, resource) +when { context.level > 0 }; + +// policy34: greater than or equal +permit (principal, action, resource) +when { context.level >= 1 }; + +// policy35: not equal +permit (principal, action, resource) +when { context.status != "blocked" }; + +// policy36: equality +permit (principal, action, resource) +when { context.role == "admin" }; + +// ===== Boolean operators ===== +// policy37: or +permit (principal, action, resource) +when { context.isAdmin || context.isModerator }; + +// policy38: and +permit (principal, action, resource) +when { context.isActive && context.isVerified }; + +// policy39: not +permit (principal, action, resource) +when { !context.isBlocked }; + +// policy40: combined boolean +permit (principal, action, resource) +when { (context.isAdmin || context.isModerator) && !context.isSuspended }; + +// policy41: chained or +permit (principal, action, resource) +when { context.role == "admin" || context.role == "editor" || context.role == "viewer" }; + +// ===== Relation operators ===== +// policy42: in (membership) +permit (principal, action, resource) +when { principal in Group::"editors" }; + +// policy43: in with set expression +permit (principal, action, resource) +when { principal in [Group::"a", Group::"b"] }; + +// policy44: in with context set +permit (principal, action, resource) +when { principal in context.groups }; + +// policy45: has (attribute presence) with ident +permit (principal, action, resource) +when { resource has owner }; + +// policy46: has with string literal +permit (principal, action, resource) +when { resource has "owner info" }; + +// policy47: like (pattern matching) +permit (principal, action, resource) +when { resource.filename like "*.txt" }; + +// policy48: like with escaped star +permit (principal, action, resource) +when { resource.name like "file\*.log" }; + +// policy49: is (type test) +permit (principal, action, resource) +when { resource is Document }; + +// policy50: is ... in (type test with membership) +permit (principal, action, resource) +when { resource is Document in Folder::"shared" }; + +// policy51: hasTag +permit (principal, action, resource) +when { resource.hasTag("env") }; + +// policy52: getTag +permit (principal, action, resource) +when { resource.getTag("env") == "prod" }; + +// ===== If-then-else ===== +// policy53: simple if-then-else +permit (principal, action, resource) +when { if context.isAdmin then true else context.level > 5 }; + +// policy54: nested if-then-else +permit (principal, action, resource) +when +{ + if + context.role == "admin" + then + true + else + if context.role == "editor" then context.level >= 3 else false +}; + +// ===== Member access ===== +// policy55: field access +permit (principal, action, resource) +when { resource.owner == principal }; + +// policy56: chained field access +permit (principal, action, resource) +when { context.request.headers.contentType == "json" }; + +// policy57: index access with string +permit (principal, action, resource) +when { resource.tags["environment"] == "production" }; + +// policy58: method call - contains +permit (principal, action, resource) +when { resource.readers.contains(principal) }; + +// policy59: method call - containsAll +permit (principal, action, resource) +when { resource.tags.containsAll(["public", "approved"]) }; + +// policy60: method call - containsAny +permit (principal, action, resource) +when { context.roles.containsAny(["admin", "reviewer"]) }; + +// policy61: method call - isEmpty +permit (principal, action, resource) +when { !resource.blocked.isEmpty() }; + +// ===== Extension functions (constructor style) ===== +// policy62: ip address +permit (principal, action, resource) +when { ip("192.168.0.1").isInRange(ip("192.168.0.0/24")) }; + +// policy63: ip methods +permit (principal, action, resource) +when +{ context.sourceIp.isIpv4() && !context.sourceIp.isLoopback() && !context.sourceIp.isMulticast() }; + +// policy64: decimal +permit (principal, action, resource) +when { decimal("1.23").lessThan(decimal("4.56")) }; + +// policy65: decimal comparison methods +permit (principal, action, resource) +when +{ + context.score.greaterThanOrEqual(decimal("3.5")) && + context.score.lessThanOrEqual(decimal("10.0")) +}; + +// policy66: datetime +permit (principal, action, resource) +when { datetime("2024-10-15T11:35:00Z") < context.expiry }; + +// policy67: datetime methods +permit (principal, action, resource) +when +{ + context.timestamp.toDate() == datetime("2024-10-15") && + context.timestamp.toTime().toHours() >= 9 +}; + +// policy68: duration +permit (principal, action, resource) +when { duration("2h30m") > context.elapsed }; + +// policy69: duration methods +permit (principal, action, resource) +when { context.timeout.toMilliseconds() < 5000 && context.retention.toDays() >= 30 }; + +// policy70: datetime offset and durationSince +permit (principal, action, resource) +when +{ + context.now.durationSince(context.lastLogin).toHours() < 24 && + context.now.offset(duration("-1h")) < context.deadline +}; + +// ===== Primary expressions ===== +// policy71: set literal +permit (principal, action, resource) +when { [1, 2, 3, 4, 5].contains(context.level) }; + +// policy72: empty set +permit (principal, action, resource) +when { [].containsAll(context.emptyList) }; + +// policy73: record literal with string keys +permit (principal, action, resource) +when { { "key": "value", "count": 42 } == context.metadata }; + +// policy74: record literal with ident keys +permit (principal, action, resource) +when { { key: "value", count: 42 } == context.metadata }; + +// policy75: empty record +permit (principal, action, resource) +when { {} == context.emptyRecord }; + +// policy76: namespaced entity reference +permit (principal, action, resource) +when { principal in App::Organization::Group::"engineering" }; + +// ===== Negation ===== +// policy77: double negation +permit (principal, action, resource) +when { !!context.flag }; + +// policy78: negation of parenthesized +forbid (principal, action, resource) +when { !(principal in Group::"family") }; + +// ===== Complex combinations ===== +// policy79: multiple conditions with complex expressions +forbid (principal, action, resource) +when { resource has sensitivityLevel } +when { resource.sensitivityLevel >= 3 } +unless { principal in Group::"clearance_level_3" }; + +// policy80: deeply nested expression +permit (principal, action, resource) +when +{ + (principal is Employee in Department::"engineering") && + resource is Repository && + (resource has isPublic && resource.isPublic || principal in resource.collaborators) +}; + +// policy81: arithmetic in comparisons with boolean logic +forbid (principal, action, resource) +when +{ + context.requestCount + 1 > context.rateLimit * 2 && + context.timestamp - context.lastReset >= 3600 +}; + +// policy82: mixed member access patterns +permit (principal, action, resource) +when +{ + resource.metadata["owner"] == principal && + resource.tags.contains("active") && + resource.permissions.containsAll(["read"]) +}; + +// policy83: has with && guard pattern +permit (principal, action, resource) +when { principal has manager && principal.manager == User::"kirk" }; + +// policy84: has with || guard pattern +permit (principal, action, resource) +when { !(principal has age) || principal.age >= 21 }; + +// policy85: in with reflexivity +permit (principal, action, resource) +when { resource in resource }; + +// policy86: complex scope with conditions +@id("admin-override") +@advice("Allows admin override for sensitive resources") +permit ( + principal is Admin in Group::"superadmins", + action in [Action::"read", Action::"write", Action::"delete"], + resource is Document in Folder::"classified" +) +when { context.mfaAuthenticated } +when { context.sourceIp.isInRange(ip("10.0.0.0/8")) } +unless { resource has locked && resource.locked }; + +// ===== Edge cases ===== +// policy87: deeply nested parentheses +permit (principal, action, resource) +when { ((((context.x)))) == 1 }; + +// policy88: long chain of && +permit (principal, action, resource) +when { context.a && context.b && context.c && context.d && context.e }; + +// policy89: long chain of || +permit (principal, action, resource) +when { context.a || context.b || context.c || context.d || context.e }; + +// policy90: entity with empty string eid +permit (principal, action, resource) +when { principal == User::"" }; + +// policy91: string with unicode escape +permit (principal, action, resource) +when { context.name == "\u{1F600}" }; + +// policy92: string with hex escape +permit (principal, action, resource) +when { context.val == "\x41\x42\x43" }; + +// policy93: multiple extension function calls +permit (principal, action, resource) +when +{ + ip(context.srcIp).isInRange(ip("10.0.0.0/8")) || + ip(context.srcIp).isInRange(ip("172.16.0.0/12")) || + ip(context.srcIp).isInRange(ip("192.168.0.0/16")) +}; + +// policy94: comparison chaining (single relop per relation in grammar) +permit (principal, action, resource) +when { context.x >= 0 && context.x <= 100 }; + +// policy95: set containment patterns +permit (principal, action, resource) +when +{ + [Action::"read", Action::"list"].contains(action) && + resource.tags.containsAny(context.allowedTags) +}; + +// policy96: record in condition +permit (principal, action, resource) +when { context.device == { os: "macOS", version: "14" } }; + +// policy97: deeply qualified entity type in is +permit (principal, action, resource) +when { principal is ExampleCo::IAM::User }; + +// policy98: whitespace variations (compact) +permit (principal, action, resource) +when { true }; + +// policy99: if-then-else as subexpression +permit (principal, action, resource) +when +{ + (if resource has owner then resource.owner == principal else false) || + principal in Group::"admins" +}; diff --git a/cedar-lean/UnitTest/parser_tests/negative/ampersand_instead_of_and.cedar b/cedar-lean/UnitTest/parser_tests/negative/ampersand_instead_of_and.cedar new file mode 100644 index 000000000..51297765e --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/ampersand_instead_of_and.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { true & false }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/annotation_after_effect.cedar b/cedar-lean/UnitTest/parser_tests/negative/annotation_after_effect.cedar new file mode 100644 index 000000000..40148cd8a --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/annotation_after_effect.cedar @@ -0,0 +1 @@ +permit @id("test") (principal, action, resource); diff --git a/cedar-lean/UnitTest/parser_tests/negative/condition_without_braces.cedar b/cedar-lean/UnitTest/parser_tests/negative/condition_without_braces.cedar new file mode 100644 index 000000000..2a9960075 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/condition_without_braces.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when context.x == 1; diff --git a/cedar-lean/UnitTest/parser_tests/negative/dot_without_field.cedar b/cedar-lean/UnitTest/parser_tests/negative/dot_without_field.cedar new file mode 100644 index 000000000..56436134b --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/dot_without_field.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { resource. }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/double_effect.cedar b/cedar-lean/UnitTest/parser_tests/negative/double_effect.cedar new file mode 100644 index 000000000..82b3af39a --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/double_effect.cedar @@ -0,0 +1 @@ +permit forbid(principal, action, resource); diff --git a/cedar-lean/UnitTest/parser_tests/negative/double_semicolon.cedar b/cedar-lean/UnitTest/parser_tests/negative/double_semicolon.cedar new file mode 100644 index 000000000..801d18553 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/double_semicolon.cedar @@ -0,0 +1 @@ +permit(principal, action, resource);; diff --git a/cedar-lean/UnitTest/parser_tests/negative/empty_scope.cedar b/cedar-lean/UnitTest/parser_tests/negative/empty_scope.cedar new file mode 100644 index 000000000..07bf3b1eb --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/empty_scope.cedar @@ -0,0 +1 @@ +permit(); diff --git a/cedar-lean/UnitTest/parser_tests/negative/empty_when_body.cedar b/cedar-lean/UnitTest/parser_tests/negative/empty_when_body.cedar new file mode 100644 index 000000000..fa2625c72 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/empty_when_body.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/eq_instead_of_double_eq.cedar b/cedar-lean/UnitTest/parser_tests/negative/eq_instead_of_double_eq.cedar new file mode 100644 index 000000000..5a067967d --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/eq_instead_of_double_eq.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { context.x = 1 }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/extra_scope_element.cedar b/cedar-lean/UnitTest/parser_tests/negative/extra_scope_element.cedar new file mode 100644 index 000000000..4747ee1b6 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/extra_scope_element.cedar @@ -0,0 +1 @@ +permit(principal, action, resource, context); diff --git a/cedar-lean/UnitTest/parser_tests/negative/invalid_annotation_placement.cedar b/cedar-lean/UnitTest/parser_tests/negative/invalid_annotation_placement.cedar new file mode 100644 index 000000000..e4f2d01f3 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/invalid_annotation_placement.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) @id("test"); diff --git a/cedar-lean/UnitTest/parser_tests/negative/invalid_effect.cedar b/cedar-lean/UnitTest/parser_tests/negative/invalid_effect.cedar new file mode 100644 index 000000000..e7b3d32e6 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/invalid_effect.cedar @@ -0,0 +1 @@ +allow(principal, action, resource); diff --git a/cedar-lean/UnitTest/parser_tests/negative/invalid_entity_ref.cedar b/cedar-lean/UnitTest/parser_tests/negative/invalid_entity_ref.cedar new file mode 100644 index 000000000..076b16555 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/invalid_entity_ref.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { User::"alice":: }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/invalid_has_number.cedar b/cedar-lean/UnitTest/parser_tests/negative/invalid_has_number.cedar new file mode 100644 index 000000000..58be4e27c --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/invalid_has_number.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { resource has 123 }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/invalid_method_syntax.cedar b/cedar-lean/UnitTest/parser_tests/negative/invalid_method_syntax.cedar new file mode 100644 index 000000000..2442edd8c --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/invalid_method_syntax.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { contains(resource.tags, "x") }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/invalid_operator_div.cedar b/cedar-lean/UnitTest/parser_tests/negative/invalid_operator_div.cedar new file mode 100644 index 000000000..7973168bd --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/invalid_operator_div.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { 10 / 2 == 5 }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/invalid_operator_mod.cedar b/cedar-lean/UnitTest/parser_tests/negative/invalid_operator_mod.cedar new file mode 100644 index 000000000..6ee7b7ea8 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/invalid_operator_mod.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { 10 % 3 == 1 }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/invalid_relop_single_eq.cedar b/cedar-lean/UnitTest/parser_tests/negative/invalid_relop_single_eq.cedar new file mode 100644 index 000000000..540e8eb02 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/invalid_relop_single_eq.cedar @@ -0,0 +1 @@ +permit(principal = User::"alice", action, resource); diff --git a/cedar-lean/UnitTest/parser_tests/negative/invalid_slot_name.cedar b/cedar-lean/UnitTest/parser_tests/negative/invalid_slot_name.cedar new file mode 100644 index 000000000..8edcfe7a7 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/invalid_slot_name.cedar @@ -0,0 +1 @@ +permit(principal == ?action, action, resource); diff --git a/cedar-lean/UnitTest/parser_tests/negative/is_with_string.cedar b/cedar-lean/UnitTest/parser_tests/negative/is_with_string.cedar new file mode 100644 index 000000000..3324521aa --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/is_with_string.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { resource is "Folder" }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/like_without_pattern.cedar b/cedar-lean/UnitTest/parser_tests/negative/like_without_pattern.cedar new file mode 100644 index 000000000..74bf96078 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/like_without_pattern.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { resource.name like }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/missing_action.cedar b/cedar-lean/UnitTest/parser_tests/negative/missing_action.cedar new file mode 100644 index 000000000..0048273a0 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/missing_action.cedar @@ -0,0 +1 @@ +permit(principal, resource); diff --git a/cedar-lean/UnitTest/parser_tests/negative/missing_close_paren.cedar b/cedar-lean/UnitTest/parser_tests/negative/missing_close_paren.cedar new file mode 100644 index 000000000..a66a218f4 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/missing_close_paren.cedar @@ -0,0 +1 @@ +permit(principal, action, resource; diff --git a/cedar-lean/UnitTest/parser_tests/negative/missing_condition_keyword.cedar b/cedar-lean/UnitTest/parser_tests/negative/missing_condition_keyword.cedar new file mode 100644 index 000000000..c0db63f9a --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/missing_condition_keyword.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) { true }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/missing_eid_in_ref.cedar b/cedar-lean/UnitTest/parser_tests/negative/missing_eid_in_ref.cedar new file mode 100644 index 000000000..2653a3db9 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/missing_eid_in_ref.cedar @@ -0,0 +1 @@ +permit(principal == User::, action, resource); diff --git a/cedar-lean/UnitTest/parser_tests/negative/missing_open_paren.cedar b/cedar-lean/UnitTest/parser_tests/negative/missing_open_paren.cedar new file mode 100644 index 000000000..3d8085a4b --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/missing_open_paren.cedar @@ -0,0 +1 @@ +permit principal, action, resource); diff --git a/cedar-lean/UnitTest/parser_tests/negative/missing_principal.cedar b/cedar-lean/UnitTest/parser_tests/negative/missing_principal.cedar new file mode 100644 index 000000000..61f9d4636 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/missing_principal.cedar @@ -0,0 +1 @@ +permit(action, resource); diff --git a/cedar-lean/UnitTest/parser_tests/negative/missing_resource.cedar b/cedar-lean/UnitTest/parser_tests/negative/missing_resource.cedar new file mode 100644 index 000000000..bf2a8ba9d --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/missing_resource.cedar @@ -0,0 +1 @@ +permit(principal, action); diff --git a/cedar-lean/UnitTest/parser_tests/negative/missing_semicolon.cedar b/cedar-lean/UnitTest/parser_tests/negative/missing_semicolon.cedar new file mode 100644 index 000000000..c973480cb --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/missing_semicolon.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) diff --git a/cedar-lean/UnitTest/parser_tests/negative/missing_when_brace.cedar b/cedar-lean/UnitTest/parser_tests/negative/missing_when_brace.cedar new file mode 100644 index 000000000..018df9b87 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/missing_when_brace.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when true; diff --git a/cedar-lean/UnitTest/parser_tests/negative/no_effect.cedar b/cedar-lean/UnitTest/parser_tests/negative/no_effect.cedar new file mode 100644 index 000000000..82cf65166 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/no_effect.cedar @@ -0,0 +1 @@ +(principal, action, resource); diff --git a/cedar-lean/UnitTest/parser_tests/negative/number_as_entity_type.cedar b/cedar-lean/UnitTest/parser_tests/negative/number_as_entity_type.cedar new file mode 100644 index 000000000..8a0326932 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/number_as_entity_type.cedar @@ -0,0 +1 @@ +permit(principal == 123::"alice", action, resource); diff --git a/cedar-lean/UnitTest/parser_tests/negative/pipe_instead_of_or.cedar b/cedar-lean/UnitTest/parser_tests/negative/pipe_instead_of_or.cedar new file mode 100644 index 000000000..da5b88a82 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/pipe_instead_of_or.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { true | false }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/reserved_word_cedar.cedar b/cedar-lean/UnitTest/parser_tests/negative/reserved_word_cedar.cedar new file mode 100644 index 000000000..3253ff85e --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/reserved_word_cedar.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { context.__cedar == true }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/slot_in_condition.cedar b/cedar-lean/UnitTest/parser_tests/negative/slot_in_condition.cedar new file mode 100644 index 000000000..aff743088 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/slot_in_condition.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { ?principal == User::"alice" }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/unclosed_list.cedar b/cedar-lean/UnitTest/parser_tests/negative/unclosed_list.cedar new file mode 100644 index 000000000..da6e8d70f --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/unclosed_list.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { [1, 2, 3 }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/unclosed_paren_expr.cedar b/cedar-lean/UnitTest/parser_tests/negative/unclosed_paren_expr.cedar new file mode 100644 index 000000000..9eb31d627 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/unclosed_paren_expr.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { (1 + 2 }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/unclosed_record.cedar b/cedar-lean/UnitTest/parser_tests/negative/unclosed_record.cedar new file mode 100644 index 000000000..35d043c77 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/unclosed_record.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { {"a": 1 }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/unclosed_string.cedar b/cedar-lean/UnitTest/parser_tests/negative/unclosed_string.cedar new file mode 100644 index 000000000..7111d9a3f --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/unclosed_string.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { "hello }; diff --git a/cedar-lean/UnitTest/parser_tests/negative/unclosed_when_brace.cedar b/cedar-lean/UnitTest/parser_tests/negative/unclosed_when_brace.cedar new file mode 100644 index 000000000..1a72c9cd3 --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/negative/unclosed_when_brace.cedar @@ -0,0 +1 @@ +permit(principal, action, resource) when { true; diff --git a/cedar-lean/UnitTest/parser_tests/stress.cedar b/cedar-lean/UnitTest/parser_tests/stress.cedar new file mode 100644 index 000000000..57cbf9cec --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/stress.cedar @@ -0,0 +1,379 @@ +// Stress tests for large policies and expressions +// 1: Long chain of && (20 operands) +permit (principal, action, resource) +when +{ + context.a1 && + context.a2 && + context.a3 && + context.a4 && + context.a5 && + context.a6 && + context.a7 && + context.a8 && + context.a9 && + context.a10 && + context.a11 && + context.a12 && + context.a13 && + context.a14 && + context.a15 && + context.a16 && + context.a17 && + context.a18 && + context.a19 && + context.a20 +}; + +// 2: Long chain of || (20 operands) +permit (principal, action, resource) +when +{ + context.a1 || + context.a2 || + context.a3 || + context.a4 || + context.a5 || + context.a6 || + context.a7 || + context.a8 || + context.a9 || + context.a10 || + context.a11 || + context.a12 || + context.a13 || + context.a14 || + context.a15 || + context.a16 || + context.a17 || + context.a18 || + context.a19 || + context.a20 +}; + +// 3: Long addition chain (20 operands) +permit (principal, action, resource) +when +{ + context.a1 + + context.a2 + + context.a3 + + context.a4 + + context.a5 + + context.a6 + + context.a7 + + context.a8 + + context.a9 + + context.a10 + + context.a11 + + context.a12 + + context.a13 + + context.a14 + + context.a15 + + context.a16 + + context.a17 + + context.a18 + + context.a19 + + context.a20 > 0 +}; + +// 4: Long multiplication chain (20 operands) +permit (principal, action, resource) +when +{ + context.a1 * + context.a2 * + context.a3 * + context.a4 * + context.a5 * + context.a6 * + context.a7 * + context.a8 * + context.a9 * + context.a10 * + context.a11 * + context.a12 * + context.a13 * + context.a14 * + context.a15 * + context.a16 * + context.a17 * + context.a18 * + context.a19 * + context.a20 > 0 +}; + +// 5: Large set literal (30 elements) +permit (principal, action, resource) +when +{ + [1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 9, + 10, + 11, + 12, + 13, + 14, + 15, + 16, + 17, + 18, + 19, + 20, + 21, + 22, + 23, + 24, + 25, + 26, + 27, + 28, + 29, + 30].contains + ( + context.x + ) +}; + +// 6: Large record literal (20 fields) +permit (principal, action, resource) +when +{ + { + field1: { subfield1: "hello", subfield2: { subsubfield1: decimal("10.000") } }, + field2: 2, + field3: 3, + field4: 4, + field5: 5, + field6: 6, + field7: 7, + field8: 8, + field9: 9, + field10: 10, + field11: 11, + field12: 12, + field13: 13, + field14: 14, + field15: 15, + field16: 16, + field17: 17, + field18: 18, + field19: 19, + field20: 20 + } == context.bigRecord +}; + +// 7: Deep member access chain (20 levels) +permit (principal, action, resource) +when { context.a.b.c.d.e.f.g.h.i.j.k.l.m.n.o.p.q.r.s.t == "deep" }; + +// 8: Many method calls chained via && +permit (principal, action, resource) +when +{ + resource.tags.contains("a") && + resource.tags.contains("b") && + resource.tags.contains("c") && + resource.tags.contains("d") && + resource.tags.contains("e") && + resource.tags.contains("f") && + resource.tags.contains("g") && + resource.tags.contains("h") && + resource.tags.contains("i") && + resource.tags.contains("j") +}; + +// 9: Deeply nested parentheses (20 levels) +permit (principal, action, resource) +when { ((((((((((((((((((((context.x)))))))))))))))))))) == 1 }; + +// 10: Deeply nested if-then-else (10 levels) +permit (principal, action, resource) +when +{ + if + context.a1 + then + if + context.a2 + then + if + context.a3 + then + if + context.a4 + then + if + context.a5 + then + if + context.a6 + then + if + context.a7 + then + if + context.a8 + then + if context.a9 then context.a10 else false + else + false + else + false + else + false + else + false + else + false + else + false + else + false + else + false +}; + +// 11: Action in large list (20 actions) +permit ( + principal, + action in + [Action::"a1", + Action::"a2", + Action::"a3", + Action::"a4", + Action::"a5", + Action::"a6", + Action::"a7", + Action::"a8", + Action::"a9", + Action::"a10", + Action::"a11", + Action::"a12", + Action::"a13", + Action::"a14", + Action::"a15", + Action::"a16", + Action::"a17", + Action::"a18", + Action::"a19", + Action::"a20"], + resource +); + +// 12: Many when/unless conditions (10 conditions) +permit (principal, action, resource) +when { context.c1 } +when { context.c2 } +when { context.c3 } +when { context.c4 } +when { context.c5 } +unless { context.c6 } +unless { context.c7 } +when { context.c8 } +when { context.c9 } +when { context.c10 }; + +// 13: Large containsAll argument (20 elements) +permit (principal, action, resource) +when +{ + resource.tags + .containsAll + ( + ["tag1", + "tag2", + "tag3", + "tag4", + "tag5", + "tag6", + "tag7", + "tag8", + "tag9", + "tag10", + "tag11", + "tag12", + "tag13", + "tag14", + "tag15", + "tag16", + "tag17", + "tag18", + "tag19", + "tag20"] + ) +}; + +// 14: Many annotations (10) +@a1("v1") +@a2("v2") +@a3("v3") +@a4("v4") +@a5("v5") +@a6("v6") +@a7("v7") +@a8("v8") +@a9("v9") +@a10("v10") +permit (principal, action, resource); + +// 15: Complex expression combining many operators +permit (principal, action, resource) +when +{ + (context.x + context.y * 2 - 1 > 0) && + (context.a || context.b || context.c) && + !(context.blocked) && + resource has owner && + resource.owner == principal && + resource.tags.contains("active") && + resource.tags.containsAll(["public", "approved"]) && + principal in Group::"editors" && + resource is Document in Folder::"shared" && + (if context.isAdmin then true else context.level >= 5) +}; + +// 16: Deeply qualified entity types (5 levels of namespace) +permit (principal, action, resource) +when +{ principal is Com::Example::Corp::IAM::User && resource is Com::Example::Corp::Storage::Document }; + +// 17: Many index accesses +permit (principal, action, resource) +when +{ + context.data["key1"] == "v1" && + context.data["key2"] == "v2" && + context.data["key3"] == "v3" && + context.data["key4"] == "v4" && + context.data["key5"] == "v5" && + context.data["key6"] == "v6" && + context.data["key7"] == "v7" && + context.data["key8"] == "v8" && + context.data["key9"] == "v9" && + context.data["key10"] == "v10" +}; + +// 18: Nested record literals +permit (principal, action, resource) +when { { outer: { middle: { inner: { deep: "value" } } } } == context.nested }; + +// 19: Set of sets (nested sets) +permit (principal, action, resource) +when { [[1, 2], [3, 4], [5, 6]].contains([1, 2]) }; + +// 20: Mixed arithmetic and comparison in complex boolean +permit (principal, action, resource) +when +{ + (context.x + 1 >= 0 && context.x - 1 <= 100) || + (context.y * 2 > 10 && context.y + context.z < 50) || + (context.a + context.b + context.c + context.d == 0) +}; diff --git a/cedar-lean/UnitTest/parser_tests/strings_and_identifiers.cedar b/cedar-lean/UnitTest/parser_tests/strings_and_identifiers.cedar new file mode 100644 index 000000000..00d9bf00d --- /dev/null +++ b/cedar-lean/UnitTest/parser_tests/strings_and_identifiers.cedar @@ -0,0 +1,97 @@ +// String literals with various escape sequences + +// Basic escapes +permit(principal, action, resource) when { context.x == "hello\nworld" }; +permit(principal, action, resource) when { context.x == "tab\there" }; +permit(principal, action, resource) when { context.x == "quote\"inside" }; +permit(principal, action, resource) when { context.x == "back\\slash" }; +permit(principal, action, resource) when { context.x == "null\0char" }; +permit(principal, action, resource) when { context.x == "single\'quote" }; + +// Hex escapes +permit(principal, action, resource) when { context.x == "\x41\x42\x43" }; +permit(principal, action, resource) when { context.x == "\x00" }; +permit(principal, action, resource) when { context.x == "\x7f" }; +permit(principal, action, resource) when { context.x == "\x61\x62\x63" }; + +// Unicode escapes +permit(principal, action, resource) when { context.x == "\u{0}" }; +permit(principal, action, resource) when { context.x == "\u{41}" }; +permit(principal, action, resource) when { context.x == "\u{1F600}" }; +permit(principal, action, resource) when { context.x == "\u{10FFFF}" }; +permit(principal, action, resource) when { context.x == "\u{61}" }; +permit(principal, action, resource) when { context.x == "\u{1f4a9}" }; + +// Empty string +permit(principal, action, resource) when { context.x == "" }; + +// String with only whitespace +permit(principal, action, resource) when { context.x == " " }; + +// String with mixed escapes +permit(principal, action, resource) when { context.x == "line1\nline2\ttab\x41\u{1F600}" }; + +// Long string +permit(principal, action, resource) when { context.x == "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" }; + +// String with special characters (not needing escape) +permit(principal, action, resource) when { context.x == "!@#$%^&*()_+-=[]{}|;':,./<>?" }; + +// String used as record key +permit(principal, action, resource) when { context.rec["key with spaces"] == "value" }; + +// String in like pattern +permit(principal, action, resource) when { context.x like "hello*world" }; +permit(principal, action, resource) when { context.x like "*" }; +permit(principal, action, resource) when { context.x like "no wildcards here" }; +permit(principal, action, resource) when { context.x like "\*literal star\*" }; +permit(principal, action, resource) when { context.x like "path/to/\*/file" }; + +// Entity UIDs with various string contents +permit(principal == User::"", action, resource); +permit(principal == User::"alice", action, resource); +permit(principal == User::"alice bob", action, resource); +permit(principal == User::"alice\"bob", action, resource); +permit(principal == User::"alice\\bob", action, resource); +permit(principal == User::"\u{1F600}", action, resource); +permit(principal == User::"\x41\x42", action, resource); +permit(principal == User::"path/to/resource", action, resource); +permit(principal == User::"user@example.com", action, resource); +permit(principal == User::"123-456-789", action, resource); + +// Namespaced entity UIDs +permit(principal == App::User::"alice", action, resource); +permit(principal == Com::Example::App::User::"alice", action, resource); +permit(principal == A::B::C::D::E::"deep", action, resource); + +// Identifiers as field names +permit(principal, action, resource) when { resource.owner == principal }; +permit(principal, action, resource) when { resource.camelCase == "x" }; +permit(principal, action, resource) when { resource.snake_case == "x" }; +permit(principal, action, resource) when { resource.MixedCase == "x" }; +permit(principal, action, resource) when { resource._leading_underscore == "x" }; +permit(principal, action, resource) when { resource.x123 == "x" }; +permit(principal, action, resource) when { resource.a == "x" }; +permit(principal, action, resource) when { resource.ALLCAPS == "x" }; + +// Identifiers as entity type names +permit(principal is User, action, resource); +permit(principal is CamelCaseType, action, resource); +permit(principal is Snake_Case_Type, action, resource); +permit(principal is A, action, resource); +permit(principal is ALLCAPS, action, resource); +permit(principal is Type123, action, resource); +permit(principal is _LeadingUnderscore, action, resource); + +// Namespaced type names in is +permit(principal, action, resource) when { resource is App::Document }; +permit(principal, action, resource) when { resource is Com::Example::Resource }; + +// has with string literal (for non-identifier attribute names) +permit(principal, action, resource) when { context has "spaces in name" }; +permit(principal, action, resource) when { context has "123startsWithNum" }; +permit(principal, action, resource) when { context has "" }; +permit(principal, action, resource) when { context has "special!@#" }; + +// Record literal with string keys containing special chars +permit(principal, action, resource) when { {"key with spaces": 1, "123num": 2} == context.x };