open import Lemmachine.Resource
module Lemmachine.Resolve (c : Resource) where
open import Lemmachine.Request
open import Lemmachine.Response
open import Lemmachine.Utils
open import Data.Bool
open import Data.Nat
open import Data.String
open import Data.Function
open import Data.Maybe
open import Data.List
open import Data.Product
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

O18 : Request → Status
O18 r with Resource.multipleChoices c r
... | false = OK
... | true  = MultipleChoices

O20 : Request → Status
O20 r with Request.reqBody r
... | nothing = NoContent
... | just _ = O18 r

P11 : Request → Status
P11 r with fetchHeader "Location" (Request.headers r)
... | nothing = O20 r
... | just _  = Created

O14 : Request → Status
O14 r with Resource.isConflict c r
... | true  = Conflict
... | false = P11 r

O16 : Request → Status
O16 r with Request.method r
... | PUT = O14 r
... | _ = O18 r

N11 : Request → Status
N11 r with isRedirect r
... | true  = SeeOther
... | false = P11 r

N16 : Request → Status
N16 r with Request.method r
... | POST = N11 r
... | _ = O16 r

M20 : Request → Status
M20 r with Resource.deleteResource c r
... | false = Accepted
... | true = O20 r

M16 : Request → Status
M16 r with Request.method r
... | DELETE = M20 r
... | _ = N16 r

L13+L14+L15+L17 : Request → Status
L13+L14+L15+L17 r with fetchHeader "If-Modified-Since" (Request.headers r)
... | nothing = M16 r
... | just clientDate with isDate clientDate
... | false = M16 r
... | true with isModified now clientDate
... | true = M16 r
... | false with Resource.lastModified c r
... | nothing = M16 r
... | just serverDate with isModified clientDate serverDate
... | true = M16 r
... | false = NotModified

J18 : Request → Status
J18 r with Request.method r
... | HEAD = NotModified
... | GET  = NotModified
... | _    = PreconditionFailed

I12+I13+K13 : Request → Status
I12+I13+K13 r with fetchHeader "If-None-Match" (Request.headers r)
... | nothing = L13+L14+L15+L17 r
... | just clientETag with "*" == clientETag
... | true = J18 r
... | false with Resource.generateETag c r
... | nothing = L13+L14+L15+L17 r
... | just serverETag with clientETag == serverETag
... | true = J18 r
... | false = L13+L14+L15+L17 r

H10+H11+H12 : Request → Status
H10+H11+H12 r with fetchHeader "If-Unmodified-Since" (Request.headers r)
... | nothing = I12+I13+K13 r
... | just clientDate with isDate clientDate
... | false = I12+I13+K13 r
... | true  with Resource.lastModified c r
... | nothing = I12+I13+K13 r
... | just serverDate with isModified clientDate serverDate
... | true = PreconditionFailed
... | false = I12+I13+K13 r

G8+G9+G11 : Request → Status
G8+G9+G11 r with fetchHeader "If-Match" (Request.headers r)
... | nothing = H10+H11+H12 r
... | just clientETag with "*" == clientETag
... | true  = H10+H11+H12 r
... | false with Resource.generateETag c r
... | nothing = PreconditionFailed
... | just serverETag with clientETag == serverETag
... | true = H10+H11+H12 r
... | false = PreconditionFailed

I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 : Request → Status
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 r   with Request.method r
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 r | PUT    with Resource.movedPermanently c r
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 _ | PUT  | just _  = MovedPermanently
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 r | PUT  | nothing   with Resource.isConflict c r
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 r | PUT  | nothing | false   = N11 r
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 _ | PUT  | nothing | true    = Conflict
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 r | _      with Resource.previouslyExisted c r
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 r | _    | true      with Resource.movedPermanently c r
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 _ | _    | true    | just _  = MovedPermanently
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 r | _    | true    | nothing   with Resource.movedTemporarily c r
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 _ | _    | true    | nothing | just _  = MovedTemporarily
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 r | POST | true    | nothing | nothing   with Resource.allowMissingPost c r
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 _ | POST | true    | nothing | nothing | false = Gone
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 r | POST | true    | nothing | nothing | true  = N11 r
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 _ | _    | true    | nothing | nothing = Gone
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 r | POST | false     with Resource.allowMissingPost c r
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 _ | POST | false   | false = NotFound
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 r | POST | false   | true  = N11 r
I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 _ | _    | false   = NotFound

H7 : Request → Status
H7 r with fetchHeader "If-Match" (Request.headers r)
... | just "*"  = PreconditionFailed
... | _ = I7+I4+P3+K7+K5+L5+M5+N5+L7+M7 r

G7 : Request → Status
G7 r with Resource.resourceExists c r
... | true  = G8+G9+G11 r
... | false = H7 r

F6+F7 : Request → Status
F6+F7 r with fetchHeader "Accept-Encoding" (Request.headers r)
... | nothing = G7 r
... | just encoding with fetch encoding (Resource.encodingsProvided c r)
... | just _  = G7 r
... | nothing = NotAcceptable

E5+E6 : Request → Status
E5+E6 r with fetchHeader "Accept-Charset" (Request.headers r)
... | nothing = F6+F7 r
... | just charset with fetch charset (Resource.charsetsProvided c r)
... | just _  = F6+F7 r
... | nothing = NotAcceptable

D4+D5 : Request → Status
D4+D5 r with fetchHeader "Accept-Language" (Request.headers r)
... | nothing = E5+E6 r
... | just language with Resource.languageAvailable c r
... | true    = E5+E6 r
... | false   = NotAcceptable

C3+C4 : Request → Status
C3+C4 r with fetchHeader "Accept" (Request.headers r)
... | nothing = D4+D5 r
... | just contentType with fetchContentType contentType
                              (Resource.contentTypesProvided c r)
... | just _  = D4+D5 r
... | nothing = NotAcceptable

B3 : Request → Status
B3 r with eqMethod (Request.method r) OPTIONS
... | true  = OK
... | false = C3+C4 r

B4 : Request → Status
B4 r with Resource.validEntityLength c r
... | true  = B3 r
... | false = RequestEntityTooLarge

B5 : Request → Status
B5 r with Resource.knownContentType c r
... | true  = B4 r
... | false = UnsupportedMediaType

B6 : Request → Status
B6 r with Resource.validContentHeaders c r
... | true  = B5 r
... | false = NotImplemented

B7 : Request → Status
B7 r with Resource.forbidden c r
... | true  = Forbidden
... | false = B6 r

B8 : Request → Status
B8 r with Resource.isAuthorized c r
... | true  = B7 r
... | false = Unauthorized

B9 : Request → Status
B9 r with Resource.malformedRequest c r
... | true  = BadRequest
... | false = B8 r

B10 : Request → Status
B10 r with any (eqMethod (Request.method r))
               (Resource.allowedMethods c r)
... | true  = B9 r
... | false = MethodNotAllowed

B11 : Request → Status
B11 r with Resource.uriTooLong c r
... | true  = RequestURItooLong
... | false = B10 r

B12 : Request → Status
B12 r with any (eqMethod (Request.method r))
               (Resource.knownMethods c r)
... | true  = B11 r
... | false = NotImplemented

B13 : Request → Status
B13 r with Resource.serviceAvailable c r
... | true  = B12 r
... | false = ServiceUnavailable

resolveStatus : Request → Status
resolveStatus r = B13 r

resolve : Application
resolve r = record {
    status = s
  ; headers = hs $ fetchAccept (Request.headers r) (Resource.contentTypesProvided c r)
  ; body = Resource.body c s
  } where
  s = resolveStatus r
  hs : Maybe String → List ResponseHeader
  hs (just s) = [ "Content-Type" , s ]
  hs nothing = []


module Luau.Syntax.FromJSON where

open import Luau.Syntax using (Block; Stat ; Expr; nil; _$_; var; function⟨_⟩_end; local_←_; function_⟨_⟩_end; return; done; _∙_)

open import Agda.Builtin.List using (List; _∷_; [])

open import FFI.Data.Aeson using (Value; Array; Object; object; array; string; fromString; lookup)
open import FFI.Data.Bool using (true; false)
open import FFI.Data.Either using (Either; Left; Right)
open import FFI.Data.Maybe using (Maybe; nothing; just)
open import FFI.Data.String using (String; _++_)
open import FFI.Data.Vector using (head; tail; null; empty)

args = fromString "args"
body = fromString "body"
func = fromString "func"
lokal = fromString "local"
list = fromString "list"
name = fromString "name"
type = fromString "type"
values = fromString "values"
vars = fromString "vars"

data Lookup : Set where
  _,_ : String → Value → Lookup
  nil : Lookup

lookupIn : List String → Object → Lookup
lookupIn [] obj = nil
lookupIn (key ∷ keys) obj with lookup (fromString key) obj
lookupIn (key ∷ keys) obj | nothing = lookupIn keys obj
lookupIn (key ∷ keys) obj | just value = (key , value)

exprFromJSON : Value → Either String Expr
exprFromObject : Object → Either String Expr
statFromJSON : Value → Either String Stat
statFromObject : Object → Either String Stat
blockFromJSON : Value → Either String Block
blockFromArray : Array → Either String Block

exprFromJSON (object obj) = exprFromObject obj
exprFromJSON val = Left "AstExpr not an object"

exprFromObject obj with lookup type obj
exprFromObject obj | just (string "AstExprCall") with lookup func obj | lookup args obj
exprFromObject obj | just (string "AstExprCall") | just value | just (array arr) with head arr
exprFromObject obj | just (string "AstExprCall") | just value | just (array arr) | just value2 with exprFromJSON value | exprFromJSON value2
exprFromObject obj | just (string "AstExprCall") | just value | just (array arr) | just value2 | Right fun | Right arg = Right (fun $ arg)
exprFromObject obj | just (string "AstExprCall") | just value | just (array arr) | just value2 | Left err | _ = Left err
exprFromObject obj | just (string "AstExprCall") | just value | just (array arr) | just value2 | _ | Left err = Left err
exprFromObject obj | just (string "AstExprCall") | just value | just (array arr) | nothing = Left ("AstExprCall empty args")
exprFromObject obj | just (string "AstExprCall") | just value | just _ = Left ("AstExprCall args not an array")
exprFromObject obj | just (string "AstExprCall") | nothing | _  = Left ("AstExprCall missing func")
exprFromObject obj | just (string "AstExprCall") | _ | nothing  = Left ("AstExprCall missing args")
exprFromObject obj | just (string "AstExprConstantNil") = Right nil
exprFromObject obj | just (string "AstExprFunction") with lookup args obj | lookup body obj
exprFromObject obj | just (string "AstExprFunction") | just (array arr) | just value with head arr | blockFromJSON value
exprFromObject obj | just (string "AstExprFunction") | just (array arr) | just value | just (string x) | Right B = Right (function⟨ x ⟩ B end)
exprFromObject obj | just (string "AstExprFunction") | just (array arr) | just value | just _ | Right B = Left "AstExprFunction args not a string array"
exprFromObject obj | just (string "AstExprFunction") | just (array arr) | just value | nothing | Right B = Left "Unsupported AstExprFunction empty args"
exprFromObject obj | just (string "AstExprFunction") | just (array arr) | just value | _ | Left err = Left err
exprFromObject obj | just (string "AstExprFunction") | just _ | just _ = Left "AstExprFunction args not an array"
exprFromObject obj | just (string "AstExprFunction") | nothing | _ = Left "AstExprFunction missing args"
exprFromObject obj | just (string "AstExprFunction") | _ | nothing = Left "AstExprFunction missing body"
exprFromObject obj | just (string "AstExprLocal") with lookup lokal obj
exprFromObject obj | just (string "AstExprLocal") | just (string x) = Right (var x)
exprFromObject obj | just (string "AstExprLocal") | just (_) = Left "AstExprLocal local not a string"
exprFromObject obj | just (string "AstExprLocal") | nothing = Left "AstExprLocal missing local"
exprFromObject obj | just (string ty) = Left ("TODO: Unsupported AstExpr " ++ ty)
exprFromObject obj | just _ = Left "AstExpr type not a string"
exprFromObject obj | nothing = Left "AstExpr missing type"

{-# NON_TERMINATING #-}
statFromJSON (object obj) = statFromObject obj
statFromJSON _ = Left "AstStat not an object"

statFromObject obj with lookup type obj
statFromObject obj | just(string "AstStatLocal") with lookup vars obj | lookup values obj
statFromObject obj | just(string "AstStatLocal") | just(array arr1) | just(array arr2) with head(arr1) | head(arr2)
statFromObject obj | just(string "AstStatLocal") | just(array arr1) | just(array arr2) | just(string x) | just(value) with exprFromJSON(value)
statFromObject obj | just(string "AstStatLocal") | just(array arr1) | just(array arr2) | just(string x) | just(value) | Right M = Right (local x ← M)
statFromObject obj | just(string "AstStatLocal") | just(array arr1) | just(array arr2) | just(string x) | just(value) | Left err = Left err
statFromObject obj | just(string "AstStatLocal") | just(array arr1) | just(array arr2) | just(string x) | nothing = Left "AstStatLocal empty values"
statFromObject obj | just(string "AstStatLocal") | just(array arr1) | just(array arr2) | just(_) | _ = Left "AstStatLocal vars not a string array"
statFromObject obj | just(string "AstStatLocal") | just(array arr1) | just(array arr2) | nothing | _ = Left "AstStatLocal empty vars"
statFromObject obj | just(string "AstStatLocal") | just(array arr1) | just(_) = Left "AstStatLocal values not an array"
statFromObject obj | just(string "AstStatLocal") | just(_) | just(_) = Left "AstStatLocal vars not an array"
statFromObject obj | just(string "AstStatLocal") | just(_) | nothing = Left "AstStatLocal missing values"
statFromObject obj | just(string "AstStatLocal") | nothing | _ = Left "AstStatLocal missing vars"
statFromObject obj | just(string "AstStatLocalFunction") with lookup name obj | lookup func obj
statFromObject obj | just(string "AstStatLocalFunction") | just (string f) | just value with exprFromJSON value
statFromObject obj | just(string "AstStatLocalFunction") | just (string f) | just value | Right (function⟨ x ⟩ B end) = Right (function f ⟨ x ⟩ B end)
statFromObject obj | just(string "AstStatLocalFunction") | just (string f) | just value | Left err = Left err
statFromObject obj | just(string "AstStatLocalFunction") | just _ | just _ | Right _ = Left "AstStatLocalFunction func is not an AstExprFunction"
statFromObject obj | just(string "AstStatLocalFunction") | just _ | just _ =  Left "AstStatLocalFunction name is not a string"
statFromObject obj | just(string "AstStatLocalFunction") | nothing | _ = Left "AstStatFunction missing name"
statFromObject obj | just(string "AstStatLocalFunction") | _ | nothing = Left "AstStatFunction missing func"
statFromObject obj | just(string "AstStatReturn") with lookup list obj
statFromObject obj | just(string "AstStatReturn") | just(array arr) with head arr
statFromObject obj | just(string "AstStatReturn") | just(array arr) | just value with exprFromJSON value
statFromObject obj | just(string "AstStatReturn") | just(array arr) | just value | Right M = Right (return M)
statFromObject obj | just(string "AstStatReturn") | just(array arr) | just value | Left err = Left err
statFromObject obj | just(string "AstStatReturn") | just(array arr) | nothing = Left "AstStatReturn empty list"
statFromObject obj | just(string "AstStatReturn") | just(_) = Left "AstStatReturn list not an array"
statFromObject obj | just(string "AstStatReturn") | nothing = Left "AstStatReturn missing list"
statFromObject obj | just (string ty) = Left ("TODO: Unsupported AstStat " ++ ty)
statFromObject obj | just _ = Left "AstStat type not a string"
statFromObject obj | nothing = Left "AstStat missing type"

blockFromJSON (array arr) = blockFromArray arr
blockFromJSON (object obj) with lookup type obj | lookup body obj
blockFromJSON (object obj) | just (string "AstStatBlock") | just value = blockFromJSON value
blockFromJSON (object obj) | just (string "AstStatBlock") | nothing = Left "AstStatBlock missing body"
blockFromJSON (object obj) | just (string ty) | _ = Left ("Unsupported AstBlock " ++ ty)
blockFromJSON (object obj) | just _ | _ = Left "AstStatBlock type not a string"
blockFromJSON (object obj) | nothing | _ = Left "AstStatBlock missing type"
blockFromJSON _ = Left "AstBlock not an array or AstStatBlock object"

blockFromArray arr with head arr
blockFromArray arr | nothing = Right done
blockFromArray arr | just value with statFromJSON value
blockFromArray arr | just value | Left err = Left err
blockFromArray arr | just value | Right S with blockFromArray(tail arr)
blockFromArray arr | just value | Right S | Left err = Left (err)
blockFromArray arr | just value | Right S | Right B  = Right (S ∙ B)


{-# OPTIONS --rewriting #-}

module Properties.StrictMode where

import Agda.Builtin.Equality.Rewrite
open import Agda.Builtin.Equality using (_≡_; refl)
open import FFI.Data.Maybe using (Maybe; just; nothing)
open import Luau.Heap using (Heap; Object; function_is_end; defn; alloc; ok; next; lookup-not-allocated) renaming (_≡_⊕_↦_ to _≡ᴴ_⊕_↦_; _[_] to _[_]ᴴ; ∅ to ∅ᴴ)
open import Luau.StrictMode using (Warningᴱ; Warningᴮ; Warningᴼ; Warningᴴᴱ; Warningᴴᴮ; UnallocatedAddress; UnboundVariable; FunctionCallMismatch; app₁; app₂; BinOpWarning; BinOpMismatch₁; BinOpMismatch₂; bin₁; bin₂; BlockMismatch; block₁; return; LocalVarMismatch; local₁; local₂; FunctionDefnMismatch; function₁; function₂; heap; expr; block; addr; +; -; *; /; <; >; <=; >=; ··)
open import Luau.Substitution using (_[_/_]ᴮ; _[_/_]ᴱ; _[_/_]ᴮunless_; var_[_/_]ᴱwhenever_)
open import Luau.Syntax using (Expr; yes; var; val; var_∈_; _⟨_⟩∈_; _$_; addr; number; bool; string; binexp; nil; function_is_end; block_is_end; done; return; local_←_; _∙_; fun; arg; name; ==; ~=)
open import Luau.Type using (Type; strict; nil; _⇒_; none; tgt; _≡ᵀ_; _≡ᴹᵀ_)
open import Luau.TypeCheck(strict) using (_⊢ᴮ_∈_; _⊢ᴱ_∈_; _⊢ᴴᴮ_▷_∈_; _⊢ᴴᴱ_▷_∈_; nil; var; addr; app; function; block; done; return; local; orNone; tgtBinOp)
open import Luau.Var using (_≡ⱽ_)
open import Luau.Addr using (_≡ᴬ_)
open import Luau.VarCtxt using (VarCtxt; ∅; _⋒_; _↦_; _⊕_↦_; _⊝_; ⊕-lookup-miss; ⊕-swap; ⊕-over) renaming (_[_] to _[_]ⱽ)
open import Luau.VarCtxt using (VarCtxt; ∅)
open import Properties.Remember using (remember; _,_)
open import Properties.Equality using (_≢_; sym; cong; trans; subst₁)
open import Properties.Dec using (Dec; yes; no)
open import Properties.Contradiction using (CONTRADICTION)
open import Properties.TypeCheck(strict) using (typeOfᴼ; typeOfᴹᴼ; typeOfⱽ; typeOfᴱ; typeOfᴮ; typeCheckᴱ; typeCheckᴮ; typeCheckᴼ; typeCheckᴴᴱ; typeCheckᴴᴮ; mustBeFunction; mustBeNumber; mustBeString)
open import Luau.OpSem using (_⟦_⟧_⟶_; _⊢_⟶*_⊣_; _⊢_⟶ᴮ_⊣_; _⊢_⟶ᴱ_⊣_; app₁; app₂; function; beta; return; block; done; local; subst; binOp₀; binOp₁; binOp₂; refl; step; +; -; *; /; <; >; ==; ~=; <=; >=; ··)
open import Luau.RuntimeError using (BinOpError; RuntimeErrorᴱ; RuntimeErrorᴮ; FunctionMismatch; BinOpMismatch₁; BinOpMismatch₂; UnboundVariable; SEGV; app₁; app₂; bin₁; bin₂; block; local; return; +; -; *; /; <; >; <=; >=; ··)
open import Luau.RuntimeType using (valueType)

src = Luau.Type.src strict

data _⊑_ (H : Heap yes) : Heap yes → Set where
  refl : (H ⊑ H)
  snoc : ∀ {H′ a V} → (H′ ≡ᴴ H ⊕ a ↦ V) → (H ⊑ H′)

rednᴱ⊑ : ∀ {H H′ M M′} → (H ⊢ M ⟶ᴱ M′ ⊣ H′) → (H ⊑ H′)
rednᴮ⊑ : ∀ {H H′ B B′} → (H ⊢ B ⟶ᴮ B′ ⊣ H′) → (H ⊑ H′)

rednᴱ⊑ (function a p) = snoc p
rednᴱ⊑ (app₁ s) = rednᴱ⊑ s
rednᴱ⊑ (app₂ p s) = rednᴱ⊑ s
rednᴱ⊑ (beta O v p q) = refl
rednᴱ⊑ (block s) = rednᴮ⊑ s
rednᴱ⊑ (return v) = refl
rednᴱ⊑ done = refl
rednᴱ⊑ (binOp₀ p) = refl
rednᴱ⊑ (binOp₁ s) = rednᴱ⊑ s
rednᴱ⊑ (binOp₂ s) = rednᴱ⊑ s

rednᴮ⊑ (local s) = rednᴱ⊑ s
rednᴮ⊑ (subst v) = refl
rednᴮ⊑ (function a p) = snoc p
rednᴮ⊑ (return s) = rednᴱ⊑ s

data LookupResult (H : Heap yes) a V : Set where
  just : (H [ a ]ᴴ ≡ just V) → LookupResult H a V
  nothing : (H [ a ]ᴴ ≡ nothing) → LookupResult H a V

lookup-⊑-nothing : ∀ {H H′} a → (H ⊑ H′) → (H′ [ a ]ᴴ ≡ nothing) → (H [ a ]ᴴ ≡ nothing)
lookup-⊑-nothing {H} a refl p = p
lookup-⊑-nothing {H} a (snoc defn) p with a ≡ᴬ next H
lookup-⊑-nothing {H} a (snoc defn) p | yes refl = refl
lookup-⊑-nothing {H} a (snoc o) p | no q = trans (lookup-not-allocated o q) p

data OrWarningᴱ {Γ M T} (H : Heap yes) (D : Γ ⊢ᴱ M ∈ T) A : Set where
  ok : A → OrWarningᴱ H D A
  warning : Warningᴱ H D → OrWarningᴱ H D A

data OrWarningᴮ {Γ B T} (H : Heap yes) (D : Γ ⊢ᴮ B ∈ T) A : Set where
  ok : A → OrWarningᴮ H D A
  warning : Warningᴮ H D → OrWarningᴮ H D A

data OrWarningᴴᴱ {Γ M T} H (D : Γ ⊢ᴴᴱ H ▷ M ∈ T) A : Set where
  ok : A → OrWarningᴴᴱ H D A
  warning : Warningᴴᴱ H D → OrWarningᴴᴱ H D A

data OrWarningᴴᴮ {Γ B T} H (D : Γ ⊢ᴴᴮ H ▷ B ∈ T) A : Set where
  ok : A → OrWarningᴴᴮ H D A
  warning : Warningᴴᴮ H D → OrWarningᴴᴮ H D A

heap-weakeningᴱ : ∀ H M {H′ Γ} → (H ⊑ H′) → OrWarningᴱ H (typeCheckᴱ H Γ M) (typeOfᴱ H Γ M ≡ typeOfᴱ H′ Γ M)
heap-weakeningᴮ : ∀ H B {H′ Γ} → (H ⊑ H′) → OrWarningᴮ H (typeCheckᴮ H Γ B) (typeOfᴮ H Γ B ≡ typeOfᴮ H′ Γ B)

heap-weakeningᴱ H (var x) h = ok refl
heap-weakeningᴱ H (val nil) h = ok refl
heap-weakeningᴱ H (val (addr a)) refl = ok refl
heap-weakeningᴱ H (val (addr a)) (snoc {a = b} defn) with a ≡ᴬ b
heap-weakeningᴱ H (val (addr a)) (snoc {a = a} defn) | yes refl = warning (UnallocatedAddress refl)
heap-weakeningᴱ H (val (addr a)) (snoc {a = b} p) | no q = ok (cong orNone (cong typeOfᴹᴼ (lookup-not-allocated p q)))
heap-weakeningᴱ H (val (number n)) h = ok refl
heap-weakeningᴱ H (val (bool b)) h = ok refl
heap-weakeningᴱ H (val (string x)) h = ok refl
heap-weakeningᴱ H (binexp M op N) h = ok refl
heap-weakeningᴱ H (M $ N) h with heap-weakeningᴱ H M h
heap-weakeningᴱ H (M $ N) h | ok p = ok (cong tgt p)
heap-weakeningᴱ H (M $ N) h | warning W = warning (app₁ W)
heap-weakeningᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) h = ok refl
heap-weakeningᴱ H (block var b ∈ T is B end) h = ok refl
heap-weakeningᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) h with heap-weakeningᴮ H B h
heap-weakeningᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) h | ok p = ok p
heap-weakeningᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) h | warning W = warning (function₂ W)
heap-weakeningᴮ H (local var x ∈ T ← M ∙ B) h with heap-weakeningᴮ H B h
heap-weakeningᴮ H (local var x ∈ T ← M ∙ B) h | ok p = ok p
heap-weakeningᴮ H (local var x ∈ T ← M ∙ B) h | warning W = warning (local₂ W)
heap-weakeningᴮ H (return M ∙ B) h with heap-weakeningᴱ H M h
heap-weakeningᴮ H (return M ∙ B) h | ok p = ok p
heap-weakeningᴮ H (return M ∙ B) h | warning W = warning (return W)
heap-weakeningᴮ H (done) h = ok refl

none-not-obj : ∀ O → none ≢ typeOfᴼ O
none-not-obj (function f ⟨ var x ∈ T ⟩∈ U is B end) ()

typeOf-val-not-none : ∀ {H Γ} v → OrWarningᴱ H (typeCheckᴱ H Γ (val v)) (none ≢ typeOfᴱ H Γ (val v))
typeOf-val-not-none nil = ok (λ ())
typeOf-val-not-none (number n) = ok (λ ())
typeOf-val-not-none (bool b) = ok (λ ())
typeOf-val-not-none (string x) = ok (λ ())
typeOf-val-not-none {H = H} (addr a) with remember (H [ a ]ᴴ)
typeOf-val-not-none {H = H} (addr a) | (just O , p) = ok (λ q → none-not-obj O (trans q (cong orNone (cong typeOfᴹᴼ p))))
typeOf-val-not-none {H = H} (addr a) | (nothing , p) = warning (UnallocatedAddress p)

substitutivityᴱ : ∀ {Γ T} H M v x → (just T ≡ typeOfⱽ H v) → (typeOfᴱ H (Γ ⊕ x ↦ T) M ≡ typeOfᴱ H Γ (M [ v / x ]ᴱ))
substitutivityᴱ-whenever-yes : ∀ {Γ T} H v x y (p : x ≡ y) → (just T ≡ typeOfⱽ H v) → (typeOfᴱ H (Γ ⊕ x ↦ T) (var y) ≡ typeOfᴱ H Γ (var y [ v / x ]ᴱwhenever (yes p)))
substitutivityᴱ-whenever-no : ∀ {Γ T} H v x y (p : x ≢ y) → (just T ≡ typeOfⱽ H v) → (typeOfᴱ H (Γ ⊕ x ↦ T) (var y) ≡ typeOfᴱ H Γ (var y [ v / x ]ᴱwhenever (no p)))
substitutivityᴮ : ∀ {Γ T} H B v x → (just T ≡ typeOfⱽ H v) → (typeOfᴮ H (Γ ⊕ x ↦ T) B ≡ typeOfᴮ H Γ (B [ v / x ]ᴮ))
substitutivityᴮ-unless-yes : ∀ {Γ Γ′ T} H B v x y (p : x ≡ y) → (just T ≡ typeOfⱽ H v) → (Γ′ ≡ Γ) → (typeOfᴮ H Γ′ B ≡ typeOfᴮ H Γ (B [ v / x ]ᴮunless (yes p)))
substitutivityᴮ-unless-no : ∀ {Γ Γ′ T} H B v x y (p : x ≢ y) → (just T ≡ typeOfⱽ H v) → (Γ′ ≡ Γ ⊕ x ↦ T) → (typeOfᴮ H Γ′ B ≡ typeOfᴮ H Γ (B [ v / x ]ᴮunless (no p)))

substitutivityᴱ H (var y) v x p with x ≡ⱽ y
substitutivityᴱ H (var y) v x p | yes q = substitutivityᴱ-whenever-yes H v x y q p
substitutivityᴱ H (var y) v x p | no q = substitutivityᴱ-whenever-no H v x y q p
substitutivityᴱ H (val w) v x p = refl
substitutivityᴱ H (binexp M op N) v x p = refl
substitutivityᴱ H (M $ N) v x p = cong tgt (substitutivityᴱ H M v x p)
substitutivityᴱ H (function f ⟨ var y ∈ T ⟩∈ U is B end) v x p = refl
substitutivityᴱ H (block var b ∈ T is B end) v x p = refl
substitutivityᴱ-whenever-yes H v x x refl q = cong orNone q
substitutivityᴱ-whenever-no H v x y p q = cong orNone ( sym (⊕-lookup-miss x y _ _ p))
substitutivityᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x p with x ≡ⱽ f
substitutivityᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x p | yes q = substitutivityᴮ-unless-yes H B v x f q p (⊕-over q)
substitutivityᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x p | no q = substitutivityᴮ-unless-no H B v x f q p (⊕-swap q)
substitutivityᴮ H (local var y ∈ T ← M ∙ B) v x p with x ≡ⱽ y
substitutivityᴮ H (local var y ∈ T  ← M ∙ B) v x p | yes q = substitutivityᴮ-unless-yes H B v x y q p (⊕-over q)
substitutivityᴮ H (local var y ∈ T  ← M ∙ B) v x p | no q =  substitutivityᴮ-unless-no H B v x y q p (⊕-swap q)
substitutivityᴮ H (return M ∙ B) v x p = substitutivityᴱ H M v x p
substitutivityᴮ H done v x p = refl
substitutivityᴮ-unless-yes H B v x x refl q refl = refl
substitutivityᴮ-unless-no H B v x y p q refl = substitutivityᴮ H B v x q

binOpPreservation : ∀ H {op v w x} → (v ⟦ op ⟧ w ⟶ x) → (tgtBinOp op ≡ typeOfᴱ H ∅ (val x))
binOpPreservation H (+ m n) = refl
binOpPreservation H (- m n) = refl
binOpPreservation H (/ m n) = refl
binOpPreservation H (* m n) = refl
binOpPreservation H (< m n) = refl
binOpPreservation H (> m n) = refl
binOpPreservation H (<= m n) = refl
binOpPreservation H (>= m n) = refl
binOpPreservation H (== v w) = refl
binOpPreservation H (~= v w) = refl
binOpPreservation H (·· v w) = refl

preservationᴱ : ∀ H M {H′ M′} → (H ⊢ M ⟶ᴱ M′ ⊣ H′) → OrWarningᴴᴱ H (typeCheckᴴᴱ H ∅ M) (typeOfᴱ H ∅ M ≡ typeOfᴱ H′ ∅ M′)
preservationᴮ : ∀ H B {H′ B′} → (H ⊢ B ⟶ᴮ B′ ⊣ H′) → OrWarningᴴᴮ H (typeCheckᴴᴮ H ∅ B) (typeOfᴮ H ∅ B ≡ typeOfᴮ H′ ∅ B′)

preservationᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) (function a defn) = ok refl
preservationᴱ H (M $ N) (app₁ s) with preservationᴱ H M s
preservationᴱ H (M $ N) (app₁ s) | ok p = ok (cong tgt p)
preservationᴱ H (M $ N) (app₁ s) | warning (expr W) = warning (expr (app₁ W))
preservationᴱ H (M $ N) (app₁ s) | warning (heap W) = warning (heap W)
preservationᴱ H (M $ N) (app₂ p s) with heap-weakeningᴱ H M (rednᴱ⊑ s)
preservationᴱ H (M $ N) (app₂ p s) | ok q = ok (cong tgt q)
preservationᴱ H (M $ N) (app₂ p s) | warning W  = warning (expr (app₁ W))
preservationᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ S ⟩∈ T is B end) v refl p) with remember (typeOfⱽ H v)
preservationᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ S ⟩∈ T is B end) v refl p) | (just U , q) with S ≡ᵀ U | T ≡ᵀ typeOfᴮ H (x ↦ S) B
preservationᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ S ⟩∈ T is B end) v refl p) | (just U , q) | yes refl | yes refl = ok (cong tgt (cong orNone (cong typeOfᴹᴼ p)))
preservationᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ S ⟩∈ T is B end) v refl p) | (just U , q) | yes refl | no r = warning (heap (addr a p (FunctionDefnMismatch r)))
preservationᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ S ⟩∈ T is B end) v refl p) | (just U , q) | no r | _ = warning (expr (FunctionCallMismatch (λ s → r (trans (trans (sym (cong src (cong orNone (cong typeOfᴹᴼ p)))) s) (cong orNone q)))))
preservationᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ S ⟩∈ T is B end) v refl p) | (nothing , q) with typeOf-val-not-none v
preservationᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ S ⟩∈ T is B end) v refl p) | (nothing , q) | ok r = CONTRADICTION (r (sym (cong orNone q)))
preservationᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ S ⟩∈ T is B end) v refl p) | (nothing , q) | warning W = warning (expr (app₂ W))
preservationᴱ H (block var b ∈ T is B end) (block s) = ok refl
preservationᴱ H (block var b ∈ T is return M ∙ B end) (return v) with T ≡ᵀ typeOfᴱ H ∅ (val v)
preservationᴱ H (block var b ∈ T is return M ∙ B end) (return v) | yes p = ok p
preservationᴱ H (block var b ∈ T is return M ∙ B end) (return v) | no p = warning (expr (BlockMismatch p))
preservationᴱ H (block var b ∈ T is done end) (done) with T ≡ᵀ nil
preservationᴱ H (block var b ∈ T is done end) (done) | yes p = ok p
preservationᴱ H (block var b ∈ T is done end) (done) | no p = warning (expr (BlockMismatch p))
preservationᴱ H (binexp M op N) (binOp₀ s) = ok (binOpPreservation H s)
preservationᴱ H (binexp M op N) (binOp₁ s) = ok refl
preservationᴱ H (binexp M op N) (binOp₂ s) = ok refl

preservationᴮ H (local var x ∈ T ← M ∙ B) (local s) with heap-weakeningᴮ H B (rednᴱ⊑ s)
preservationᴮ H (local var x ∈ T ← M ∙ B) (local s) | ok p = ok p
preservationᴮ H (local var x ∈ T ← M ∙ B) (local s) | warning W = warning (block (local₂ W))
preservationᴮ H (local var x ∈ T ← M ∙ B) (subst v) with remember (typeOfⱽ H v)
preservationᴮ H (local var x ∈ T ← M ∙ B) (subst v) | (just U , p) with T ≡ᵀ U
preservationᴮ H (local var x ∈ T ← M ∙ B) (subst v) | (just T , p) | yes refl = ok (substitutivityᴮ H B v x (sym p))
preservationᴮ H (local var x ∈ T ← M ∙ B) (subst v) | (just U , p) | no q = warning (block (LocalVarMismatch (λ r → q (trans r (cong orNone p)))))
preservationᴮ H (local var x ∈ T ← M ∙ B) (subst v) | (nothing , p) with typeOf-val-not-none v
preservationᴮ H (local var x ∈ T ← M ∙ B) (subst v) | (nothing , p) | ok q = CONTRADICTION (q (sym (cong orNone p)))
preservationᴮ H (local var x ∈ T ← M ∙ B) (subst v) | (nothing , p) | warning W = warning (block (local₁ W))
preservationᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) (function a defn) with heap-weakeningᴮ H B (snoc defn)
preservationᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) (function a defn) | ok r = ok (trans r (substitutivityᴮ _ B (addr a) f refl))
preservationᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) (function a defn) | warning W = warning (block (function₂ W))
preservationᴮ H (return M ∙ B) (return s) with preservationᴱ H M s
preservationᴮ H (return M ∙ B) (return s) | ok p = ok p
preservationᴮ H (return M ∙ B) (return s) | warning (expr W) = warning (block (return W))
preservationᴮ H (return M ∙ B) (return s) | warning (heap W) = warning (heap W)

reflect-substitutionᴱ : ∀ {Γ T} H M v x → (just T ≡ typeOfⱽ H v) → Warningᴱ H (typeCheckᴱ H Γ (M [ v / x ]ᴱ)) → Warningᴱ H (typeCheckᴱ H (Γ ⊕ x ↦ T) M)
reflect-substitutionᴱ-whenever-yes : ∀ {Γ T} H v x y (p : x ≡ y) → (just T ≡ typeOfⱽ H v) → Warningᴱ H (typeCheckᴱ H Γ (var y [ v / x ]ᴱwhenever yes p)) → Warningᴱ H (typeCheckᴱ H (Γ ⊕ x ↦ T) (var y))
reflect-substitutionᴱ-whenever-no : ∀ {Γ T} H v x y (p : x ≢ y) → (just T ≡ typeOfⱽ H v) → Warningᴱ H (typeCheckᴱ H Γ (var y [ v / x ]ᴱwhenever no p)) → Warningᴱ H (typeCheckᴱ H  (Γ ⊕ x ↦ T) (var y))
reflect-substitutionᴮ : ∀ {Γ T} H B v x → (just T ≡ typeOfⱽ H v) → Warningᴮ H (typeCheckᴮ H Γ (B [ v / x ]ᴮ)) → Warningᴮ H (typeCheckᴮ H (Γ ⊕ x ↦ T) B)
reflect-substitutionᴮ-unless-yes : ∀ {Γ Γ′ T} H B v x y (r : x ≡ y) → (just T ≡ typeOfⱽ H v) → (Γ′ ≡ Γ) → Warningᴮ H (typeCheckᴮ H Γ (B [ v / x ]ᴮunless yes r)) → Warningᴮ H (typeCheckᴮ H Γ′ B)
reflect-substitutionᴮ-unless-no : ∀ {Γ Γ′ T} H B v x y (r : x ≢ y) → (just T ≡ typeOfⱽ H v) → (Γ′ ≡ Γ ⊕ x ↦ T) → Warningᴮ H (typeCheckᴮ H Γ (B [ v / x ]ᴮunless no r)) → Warningᴮ H (typeCheckᴮ H Γ′ B)

reflect-substitutionᴱ H (var y) v x p W with x ≡ⱽ y
reflect-substitutionᴱ H (var y) v x p W | yes r = reflect-substitutionᴱ-whenever-yes H v x y r p W
reflect-substitutionᴱ H (var y) v x p W | no r = reflect-substitutionᴱ-whenever-no H v x y r p W
reflect-substitutionᴱ H (val (addr a)) v x p (UnallocatedAddress r) = UnallocatedAddress r
reflect-substitutionᴱ H (M $ N) v x p (FunctionCallMismatch q) = FunctionCallMismatch (λ s → q (trans (cong src (sym (substitutivityᴱ H M v x p))) (trans s (substitutivityᴱ H N v x p))))
reflect-substitutionᴱ H (M $ N) v x p (app₁ W) = app₁ (reflect-substitutionᴱ H M v x p W)
reflect-substitutionᴱ H (M $ N) v x p (app₂ W) = app₂ (reflect-substitutionᴱ H N v x p W)
reflect-substitutionᴱ H (function f ⟨ var y ∈ T ⟩∈ U is B end) v x p (FunctionDefnMismatch q) with (x ≡ⱽ y)
reflect-substitutionᴱ H (function f ⟨ var y ∈ T ⟩∈ U is B end) v x p (FunctionDefnMismatch q) | yes r = FunctionDefnMismatch (λ s → q (trans s (substitutivityᴮ-unless-yes H B v x y r p (⊕-over r))))
reflect-substitutionᴱ H (function f ⟨ var y ∈ T ⟩∈ U is B end) v x p (FunctionDefnMismatch q) | no r = FunctionDefnMismatch (λ s → q (trans s (substitutivityᴮ-unless-no H B v x y r p (⊕-swap r))))
reflect-substitutionᴱ H (function f ⟨ var y ∈ T ⟩∈ U is B end) v x p (function₁ W) with (x ≡ⱽ y)
reflect-substitutionᴱ H (function f ⟨ var y ∈ T ⟩∈ U is B end) v x p (function₁ W) | yes r = function₁ (reflect-substitutionᴮ-unless-yes H B v x y r p (⊕-over r) W)
reflect-substitutionᴱ H (function f ⟨ var y ∈ T ⟩∈ U is B end) v x p (function₁ W) | no r = function₁ (reflect-substitutionᴮ-unless-no H B v x y r p (⊕-swap r) W)
reflect-substitutionᴱ H (block var b ∈ T is B end) v x p (BlockMismatch q) = BlockMismatch (λ r → q (trans r (substitutivityᴮ H B v x p)))
reflect-substitutionᴱ H (block var b ∈ T is B end) v x p (block₁ W) = block₁ (reflect-substitutionᴮ H B v x p W)
reflect-substitutionᴱ H (binexp M op N) x v p (BinOpMismatch₁ q) = BinOpMismatch₁ (subst₁ (BinOpWarning op) (sym (substitutivityᴱ H M x v p)) q)
reflect-substitutionᴱ H (binexp M op N) x v p (BinOpMismatch₂ q) = BinOpMismatch₂ (subst₁ (BinOpWarning op) (sym (substitutivityᴱ H N x v p)) q)
reflect-substitutionᴱ H (binexp M op N) x v p (bin₁ W) = bin₁ (reflect-substitutionᴱ H M x v p W)
reflect-substitutionᴱ H (binexp M op N) x v p (bin₂ W) = bin₂ (reflect-substitutionᴱ H N x v p W)

reflect-substitutionᴱ-whenever-no H v x y p q (UnboundVariable r) = UnboundVariable (trans (sym (⊕-lookup-miss x y _ _ p)) r)
reflect-substitutionᴱ-whenever-yes H (addr a) x x refl p (UnallocatedAddress q) with trans p (cong typeOfᴹᴼ q)
reflect-substitutionᴱ-whenever-yes H (addr a) x x refl p (UnallocatedAddress q) | ()

reflect-substitutionᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x p (FunctionDefnMismatch q) with (x ≡ⱽ y)
reflect-substitutionᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x p (FunctionDefnMismatch q) | yes r = FunctionDefnMismatch (λ s → q (trans s (substitutivityᴮ-unless-yes H C v x y r p (⊕-over r))))
reflect-substitutionᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x p (FunctionDefnMismatch q) | no r = FunctionDefnMismatch (λ s → q (trans s (substitutivityᴮ-unless-no H C v x y r p (⊕-swap r))))
reflect-substitutionᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x p (function₁ W) with (x ≡ⱽ y)
reflect-substitutionᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x p (function₁ W) | yes r = function₁ (reflect-substitutionᴮ-unless-yes H C v x y r p (⊕-over r) W)
reflect-substitutionᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x p (function₁ W) | no r = function₁ (reflect-substitutionᴮ-unless-no H C v x y r p (⊕-swap r) W)
reflect-substitutionᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x p (function₂ W) with (x ≡ⱽ f)
reflect-substitutionᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x p (function₂ W)| yes r = function₂ (reflect-substitutionᴮ-unless-yes H B v x f r p (⊕-over r) W)
reflect-substitutionᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) v x p (function₂ W)| no r = function₂ (reflect-substitutionᴮ-unless-no H B v x f r p (⊕-swap r) W)
reflect-substitutionᴮ H (local var y ∈ T ← M ∙ B) v x p (LocalVarMismatch q) = LocalVarMismatch (λ r → q (trans r (substitutivityᴱ H M v x p)))
reflect-substitutionᴮ H (local var y ∈ T ← M ∙ B) v x p (local₁ W) = local₁ (reflect-substitutionᴱ H M v x p W)
reflect-substitutionᴮ H (local var y ∈ T ← M ∙ B) v x p (local₂ W) with (x ≡ⱽ y)
reflect-substitutionᴮ H (local var y ∈ T ← M ∙ B) v x p (local₂ W) | yes r = local₂ (reflect-substitutionᴮ-unless-yes H B v x y r p (⊕-over r) W)
reflect-substitutionᴮ H (local var y ∈ T ← M ∙ B) v x p (local₂ W) | no r = local₂ (reflect-substitutionᴮ-unless-no H B v x y r p (⊕-swap r) W)
reflect-substitutionᴮ H (return M ∙ B) v x p (return W) = return (reflect-substitutionᴱ H M v x p W)

reflect-substitutionᴮ-unless-yes H B v x y r p refl W = W
reflect-substitutionᴮ-unless-no H B v x y r p refl W = reflect-substitutionᴮ H B v x p W

reflect-weakeningᴱ : ∀ H M {H′ Γ} → (H ⊑ H′) → Warningᴱ H′ (typeCheckᴱ H′ Γ M) → Warningᴱ H (typeCheckᴱ H Γ M)
reflect-weakeningᴮ : ∀ H B {H′ Γ} → (H ⊑ H′) → Warningᴮ H′ (typeCheckᴮ H′ Γ B) → Warningᴮ H (typeCheckᴮ H Γ B)

reflect-weakeningᴱ H (var x) h (UnboundVariable p) = (UnboundVariable p)
reflect-weakeningᴱ H (val (addr a)) h (UnallocatedAddress p) = UnallocatedAddress (lookup-⊑-nothing a h p)
reflect-weakeningᴱ H (M $ N) h (FunctionCallMismatch p) with heap-weakeningᴱ H M h | heap-weakeningᴱ H N h
reflect-weakeningᴱ H (M $ N) h (FunctionCallMismatch p) | ok q₁ | ok q₂ = FunctionCallMismatch (λ r → p (trans (cong src (sym q₁)) (trans r q₂)))
reflect-weakeningᴱ H (M $ N) h (FunctionCallMismatch p) | warning W | _ = app₁ W
reflect-weakeningᴱ H (M $ N) h (FunctionCallMismatch p) | _ | warning W = app₂ W
reflect-weakeningᴱ H (M $ N) h (app₁ W) = app₁ (reflect-weakeningᴱ H M h W)
reflect-weakeningᴱ H (M $ N) h (app₂ W) = app₂ (reflect-weakeningᴱ H N h W)
reflect-weakeningᴱ H (binexp M op N) h (BinOpMismatch₁ p) with heap-weakeningᴱ H M h
reflect-weakeningᴱ H (binexp M op N) h (BinOpMismatch₁ p) | ok q = BinOpMismatch₁ (subst₁ (BinOpWarning op) (sym q) p)
reflect-weakeningᴱ H (binexp M op N) h (BinOpMismatch₁ p) | warning W = bin₁ W
reflect-weakeningᴱ H (binexp M op N) h (BinOpMismatch₂ p) with heap-weakeningᴱ H N h
reflect-weakeningᴱ H (binexp M op N) h (BinOpMismatch₂ p) | ok q = BinOpMismatch₂ (subst₁ (BinOpWarning op) (sym q) p)
reflect-weakeningᴱ H (binexp M op N) h (BinOpMismatch₂ p) | warning W = bin₂ W
reflect-weakeningᴱ H (binexp M op N) h (bin₁ W′) = bin₁ (reflect-weakeningᴱ H M h W′)
reflect-weakeningᴱ H (binexp M op N) h (bin₂ W′) = bin₂ (reflect-weakeningᴱ H N h W′)
reflect-weakeningᴱ H (function f ⟨ var y ∈ T ⟩∈ U is B end) h (FunctionDefnMismatch p) with heap-weakeningᴮ H B h
reflect-weakeningᴱ H (function f ⟨ var y ∈ T ⟩∈ U is B end) h (FunctionDefnMismatch p) | ok q = FunctionDefnMismatch (λ r → p (trans r q))
reflect-weakeningᴱ H (function f ⟨ var y ∈ T ⟩∈ U is B end) h (FunctionDefnMismatch p) | warning W = function₁ W
reflect-weakeningᴱ H (function f ⟨ var y ∈ T ⟩∈ U is B end) h (function₁ W) = function₁ (reflect-weakeningᴮ H B h W)
reflect-weakeningᴱ H (block var b ∈ T is B end) h (BlockMismatch p) with heap-weakeningᴮ H B h
reflect-weakeningᴱ H (block var b ∈ T is B end) h (BlockMismatch p) | ok q = BlockMismatch (λ r → p (trans r q))
reflect-weakeningᴱ H (block var b ∈ T is B end) h (BlockMismatch p) | warning W = block₁ W
reflect-weakeningᴱ H (block var b ∈ T is B end) h (block₁ W) = block₁ (reflect-weakeningᴮ H B h W)

reflect-weakeningᴮ H (return M ∙ B) h (return W) = return (reflect-weakeningᴱ H M h W)
reflect-weakeningᴮ H (local var y ∈ T ← M ∙ B) h (LocalVarMismatch p) with heap-weakeningᴱ H M h
reflect-weakeningᴮ H (local var y ∈ T ← M ∙ B) h (LocalVarMismatch p) | ok q = LocalVarMismatch (λ r → p (trans r q))
reflect-weakeningᴮ H (local var y ∈ T ← M ∙ B) h (LocalVarMismatch p) | warning W = local₁ W
reflect-weakeningᴮ H (local var y ∈ T ← M ∙ B) h (local₁ W) = local₁ (reflect-weakeningᴱ H M h W)
reflect-weakeningᴮ H (local var y ∈ T ← M ∙ B) h (local₂ W) = local₂ (reflect-weakeningᴮ H B h W)
reflect-weakeningᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) h (FunctionDefnMismatch p) with heap-weakeningᴮ H C h
reflect-weakeningᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) h (FunctionDefnMismatch p) | ok q = FunctionDefnMismatch (λ r → p (trans r q))
reflect-weakeningᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) h (FunctionDefnMismatch p) | warning W = function₁ W
reflect-weakeningᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) h (function₁ W) = function₁ (reflect-weakeningᴮ H C h W)
reflect-weakeningᴮ H (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) h (function₂ W) = function₂ (reflect-weakeningᴮ H B h W)

reflect-weakeningᴼ : ∀ H O {H′} → (H ⊑ H′) → Warningᴼ H′ (typeCheckᴼ H′ O) → Warningᴼ H (typeCheckᴼ H O)
reflect-weakeningᴼ H (just (function f ⟨ var x ∈ T ⟩∈ U is B end)) h (FunctionDefnMismatch p) with heap-weakeningᴮ H B h
reflect-weakeningᴼ H (just (function f ⟨ var x ∈ T ⟩∈ U is B end)) h (FunctionDefnMismatch p) | ok q = FunctionDefnMismatch (λ r → p (trans r q))
reflect-weakeningᴼ H (just (function f ⟨ var x ∈ T ⟩∈ U is B end)) h (FunctionDefnMismatch p) | warning W = function₁ W
reflect-weakeningᴼ H (just (function f ⟨ var x ∈ T ⟩∈ U is B end)) h (function₁ W′) = function₁ (reflect-weakeningᴮ H B h W′)

reflectᴱ : ∀ H M {H′ M′} → (H ⊢ M ⟶ᴱ M′ ⊣ H′) → Warningᴱ H′ (typeCheckᴱ H′ ∅ M′) → Warningᴴᴱ H (typeCheckᴴᴱ H ∅ M)
reflectᴮ : ∀ H B {H′ B′} → (H ⊢ B ⟶ᴮ B′ ⊣ H′) → Warningᴮ H′ (typeCheckᴮ H′ ∅ B′) → Warningᴴᴮ H (typeCheckᴴᴮ H ∅ B)

reflectᴱ H (M $ N) (app₁ s) (FunctionCallMismatch p) with preservationᴱ H M s | heap-weakeningᴱ H N (rednᴱ⊑ s)
reflectᴱ H (M $ N) (app₁ s) (FunctionCallMismatch p) | ok q | ok q′ = expr (FunctionCallMismatch (λ r → p (trans (trans (cong src (sym q)) r) q′)))
reflectᴱ H (M $ N) (app₁ s) (FunctionCallMismatch p) | warning (expr W) | _ = expr (app₁ W)
reflectᴱ H (M $ N) (app₁ s) (FunctionCallMismatch p) | warning (heap W) | _ = heap W
reflectᴱ H (M $ N) (app₁ s) (FunctionCallMismatch p) | _ | warning W  = expr (app₂ W)
reflectᴱ H (M $ N) (app₁ s) (app₁ W′) with reflectᴱ H M s W′
reflectᴱ H (M $ N) (app₁ s) (app₁ W′) | heap W = heap W
reflectᴱ H (M $ N) (app₁ s) (app₁ W′) | expr W = expr (app₁ W)
reflectᴱ H (M $ N) (app₁ s) (app₂ W′) = expr (app₂ (reflect-weakeningᴱ H N (rednᴱ⊑ s) W′))
reflectᴱ H (M $ N) (app₂ p s) (FunctionCallMismatch p′) with heap-weakeningᴱ H (val p) (rednᴱ⊑ s) | preservationᴱ H N s
reflectᴱ H (M $ N) (app₂ p s) (FunctionCallMismatch p′) | ok q | ok q′ = expr (FunctionCallMismatch (λ r → p′ (trans (trans (cong src (sym q)) r) q′)))
reflectᴱ H (M $ N) (app₂ p s) (FunctionCallMismatch p′) | warning W | _ = expr (app₁ W)
reflectᴱ H (M $ N) (app₂ p s) (FunctionCallMismatch p′) | _ | warning (expr W) = expr (app₂ W)
reflectᴱ H (M $ N) (app₂ p s) (FunctionCallMismatch p′) | _ | warning (heap W) = heap W
reflectᴱ H (M $ N) (app₂ p s) (app₁ W′) = expr (app₁ (reflect-weakeningᴱ H M (rednᴱ⊑ s) W′))
reflectᴱ H (M $ N) (app₂ p s) (app₂ W′) with reflectᴱ H N s W′
reflectᴱ H (M $ N) (app₂ p s) (app₂ W′) | heap W = heap W
reflectᴱ H (M $ N) (app₂ p s) (app₂ W′) | expr W = expr (app₂ W)
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (BlockMismatch q) with remember (typeOfⱽ H v)
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (BlockMismatch q) | (just S , r) with S ≡ᵀ T
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (BlockMismatch q) | (just T , r) | yes refl = heap (addr a p (FunctionDefnMismatch (λ s → q (trans s (substitutivityᴮ H B v x (sym r))))))
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (BlockMismatch q) | (just S , r) | no s = expr (FunctionCallMismatch (λ t → s (trans (cong orNone (sym r)) (trans (sym t) (cong src (cong orNone (cong typeOfᴹᴼ p)))))))
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (BlockMismatch q) | (nothing , r) with typeOf-val-not-none v
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (BlockMismatch q) | (nothing , r) | ok s = CONTRADICTION (s (cong orNone (sym r)))
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (BlockMismatch q) | (nothing , r) | warning W = expr (app₂ W)
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (block₁ W′) with remember (typeOfⱽ H v)
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (block₁ W′) | (just S , q) with S ≡ᵀ T
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (block₁ W′) | (just T , q) | yes refl = heap (addr a p (function₁ (reflect-substitutionᴮ H B v x (sym q) W′)))
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (block₁ W′) | (just S , q) | no r = expr (FunctionCallMismatch (λ s → r (trans (cong orNone (sym q)) (trans (sym s) (cong src (cong orNone (cong typeOfᴹᴼ p)))))))
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (block₁ W′) | (nothing , q) with typeOf-val-not-none v
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (block₁ W′) | (nothing , q) | ok r = CONTRADICTION (r (cong orNone (sym q)))
reflectᴱ H (val (addr a) $ N) (beta (function f ⟨ var x ∈ T ⟩∈ U is B end) v refl p) (block₁ W′) | (nothing , q) | warning W = expr (app₂ W)
reflectᴱ H (block var b ∈ T is B end) (block s) (BlockMismatch p) with preservationᴮ H B s
reflectᴱ H (block var b ∈ T is B end) (block s) (BlockMismatch p) | ok q = expr (BlockMismatch (λ r → p (trans r q)))
reflectᴱ H (block var b ∈ T is B end) (block s) (BlockMismatch p) | warning (heap W) = heap W
reflectᴱ H (block var b ∈ T is B end) (block s) (BlockMismatch p) | warning (block W) = expr (block₁ W)
reflectᴱ H (block var b ∈ T is B end) (block s) (block₁ W′) with reflectᴮ H B s W′
reflectᴱ H (block var b ∈ T is B end) (block s) (block₁ W′) | heap W = heap W
reflectᴱ H (block var b ∈ T is B end) (block s) (block₁ W′) | block W = expr (block₁ W)
reflectᴱ H (block var b ∈ T is B end) (return v) W′ = expr (block₁ (return W′))
reflectᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) (function a defn) (UnallocatedAddress ())
reflectᴱ H (binexp M op N) (binOp₀ ()) (UnallocatedAddress p)
reflectᴱ H (binexp M op N) (binOp₁ s) (BinOpMismatch₁ p) with preservationᴱ H M s
reflectᴱ H (binexp M op N) (binOp₁ s) (BinOpMismatch₁ p) | ok q = expr (BinOpMismatch₁ (subst₁ (BinOpWarning op) (sym q) p))
reflectᴱ H (binexp M op N) (binOp₁ s) (BinOpMismatch₁ p) | warning (heap W) = heap W
reflectᴱ H (binexp M op N) (binOp₁ s) (BinOpMismatch₁ p) | warning (expr W) = expr (bin₁ W)
reflectᴱ H (binexp M op N) (binOp₁ s) (BinOpMismatch₂ p) with heap-weakeningᴱ H N (rednᴱ⊑ s)
reflectᴱ H (binexp M op N) (binOp₁ s) (BinOpMismatch₂ p) | ok q = expr (BinOpMismatch₂ ((subst₁ (BinOpWarning op) (sym q) p)))
reflectᴱ H (binexp M op N) (binOp₁ s) (BinOpMismatch₂ p) | warning W = expr (bin₂ W)
reflectᴱ H (binexp M op N) (binOp₁ s) (bin₁ W′) with reflectᴱ H M s W′
reflectᴱ H (binexp M op N) (binOp₁ s) (bin₁ W′) | heap W = heap W
reflectᴱ H (binexp M op N) (binOp₁ s) (bin₁ W′) | expr W = expr (bin₁ W)
reflectᴱ H (binexp M op N) (binOp₁ s) (bin₂ W′) = expr (bin₂ (reflect-weakeningᴱ H N (rednᴱ⊑ s) W′))
reflectᴱ H (binexp M op N) (binOp₂ s) (BinOpMismatch₁ p) with heap-weakeningᴱ H M (rednᴱ⊑ s)
reflectᴱ H (binexp M op N) (binOp₂ s) (BinOpMismatch₁ p) | ok q = expr (BinOpMismatch₁ (subst₁ (BinOpWarning op) (sym q) p))
reflectᴱ H (binexp M op N) (binOp₂ s) (BinOpMismatch₁ p) | warning W = expr (bin₁ W)
reflectᴱ H (binexp M op N) (binOp₂ s) (BinOpMismatch₂ p) with preservationᴱ H N s
reflectᴱ H (binexp M op N) (binOp₂ s) (BinOpMismatch₂ p) | ok q = expr (BinOpMismatch₂ (subst₁ (BinOpWarning op) (sym q) p))
reflectᴱ H (binexp M op N) (binOp₂ s) (BinOpMismatch₂ p) | warning (heap W) = heap W
reflectᴱ H (binexp M op N) (binOp₂ s) (BinOpMismatch₂ p) | warning (expr W) = expr (bin₂ W)
reflectᴱ H (binexp M op N) (binOp₂ s) (bin₁ W′) = expr (bin₁ (reflect-weakeningᴱ H M (rednᴱ⊑ s) W′))
reflectᴱ H (binexp M op N) (binOp₂ s) (bin₂ W′) with reflectᴱ H N s W′
reflectᴱ H (binexp M op N) (binOp₂ s) (bin₂ W′) | heap W = heap W
reflectᴱ H (binexp M op N) (binOp₂ s) (bin₂ W′) | expr W = expr (bin₂ W)

reflectᴮ H (local var x ∈ T ← M ∙ B) (local s) (LocalVarMismatch p) with preservationᴱ H M s
reflectᴮ H (local var x ∈ T ← M ∙ B) (local s) (LocalVarMismatch p) | ok q = block (LocalVarMismatch (λ r → p (trans r q)))
reflectᴮ H (local var x ∈ T ← M ∙ B) (local s) (LocalVarMismatch p) | warning (expr W) = block (local₁ W)
reflectᴮ H (local var x ∈ T ← M ∙ B) (local s) (LocalVarMismatch p) | warning (heap W) = heap W
reflectᴮ H (local var x ∈ T ← M ∙ B) (local s) (local₁ W′) with reflectᴱ H M s W′
reflectᴮ H (local var x ∈ T ← M ∙ B) (local s) (local₁ W′) | heap W = heap W
reflectᴮ H (local var x ∈ T ← M ∙ B) (local s) (local₁ W′) | expr W = block (local₁ W)
reflectᴮ H (local var x ∈ T ← M ∙ B) (local s) (local₂ W′) = block (local₂ (reflect-weakeningᴮ H B (rednᴱ⊑ s) W′))
reflectᴮ H (local var x ∈ T ← M ∙ B) (subst v) W′ with remember (typeOfⱽ H v)
reflectᴮ H (local var x ∈ T ← M ∙ B) (subst v) W′ | (just S , p) with S ≡ᵀ T
reflectᴮ H (local var x ∈ T ← M ∙ B) (subst v) W′ | (just T , p) | yes refl = block (local₂ (reflect-substitutionᴮ H B v x (sym p) W′))
reflectᴮ H (local var x ∈ T ← M ∙ B) (subst v) W′ | (just S , p) | no q = block (LocalVarMismatch (λ r → q (trans (cong orNone (sym p)) (sym r))))
reflectᴮ H (local var x ∈ T ← M ∙ B) (subst v) W′ | (nothing , p) with typeOf-val-not-none v
reflectᴮ H (local var x ∈ T ← M ∙ B) (subst v) W′ | (nothing , p) | ok r = CONTRADICTION (r (cong orNone (sym p)))
reflectᴮ H (local var x ∈ T ← M ∙ B) (subst v) W′ | (nothing , p) | warning W = block (local₁ W)
reflectᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) (function a defn) W′ = block (function₂ (reflect-weakeningᴮ H B (snoc defn) (reflect-substitutionᴮ _ B (addr a) f refl W′)))
reflectᴮ H (return M ∙ B) (return s) (return W′) with reflectᴱ H M s W′
reflectᴮ H (return M ∙ B) (return s) (return W′) | heap W = heap W
reflectᴮ H (return M ∙ B) (return s) (return W′) | expr W = block (return W)

reflectᴴᴱ : ∀ H M {H′ M′} → (H ⊢ M ⟶ᴱ M′ ⊣ H′) → Warningᴴᴱ H′ (typeCheckᴴᴱ H′ ∅ M′) → Warningᴴᴱ H (typeCheckᴴᴱ H ∅ M)
reflectᴴᴮ : ∀ H B {H′ B′} → (H ⊢ B ⟶ᴮ B′ ⊣ H′) → Warningᴴᴮ H′ (typeCheckᴴᴮ H′ ∅ B′) → Warningᴴᴮ H (typeCheckᴴᴮ H ∅ B)

reflectᴴᴱ H M s (expr W′) = reflectᴱ H M s W′
reflectᴴᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) (function a p) (heap (addr b refl W′)) with b ≡ᴬ a
reflectᴴᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) (function a defn) (heap (addr a refl (FunctionDefnMismatch p))) | yes refl with heap-weakeningᴮ H B (snoc defn)
reflectᴴᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) (function a defn) (heap (addr a refl (FunctionDefnMismatch p))) | yes refl | ok r = expr (FunctionDefnMismatch λ q → p (trans q r))
reflectᴴᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) (function a defn) (heap (addr a refl (FunctionDefnMismatch p))) | yes refl | warning W = expr (function₁ W)
reflectᴴᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) (function a defn) (heap (addr a refl (function₁ W′))) | yes refl = expr (function₁ (reflect-weakeningᴮ H B (snoc defn) W′))
reflectᴴᴱ H (function f ⟨ var x ∈ T ⟩∈ U is B end) (function a p) (heap (addr b refl W′)) | no r = heap (addr b (lookup-not-allocated p r) (reflect-weakeningᴼ H _ (snoc p) W′))
reflectᴴᴱ H (M $ N) (app₁ s) (heap W′) with reflectᴴᴱ H M s (heap W′)
reflectᴴᴱ H (M $ N) (app₁ s) (heap W′) | heap W = heap W
reflectᴴᴱ H (M $ N) (app₁ s) (heap W′) | expr W = expr (app₁ W)
reflectᴴᴱ H (M $ N) (app₂ p s) (heap W′) with reflectᴴᴱ H N s (heap W′)
reflectᴴᴱ H (M $ N) (app₂ p s) (heap W′) | heap W = heap W
reflectᴴᴱ H (M $ N) (app₂ p s) (heap W′) | expr W = expr (app₂ W)
reflectᴴᴱ H (M $ N) (beta O v p q) (heap W′) = heap W′
reflectᴴᴱ H (block var b ∈ T is B end) (block s) (heap W′) with reflectᴴᴮ H B s (heap W′)
reflectᴴᴱ H (block var b ∈ T is B end) (block s) (heap W′) | heap W = heap W
reflectᴴᴱ H (block var b ∈ T is B end) (block s) (heap W′) | block W = expr (block₁ W)
reflectᴴᴱ H (block var b ∈ T is return N ∙ B end) (return v) (heap W′) = heap W′
reflectᴴᴱ H (block var b ∈ T is done end) done (heap W′) = heap W′
reflectᴴᴱ H (binexp M op N) (binOp₀ s) (heap W′) = heap W′
reflectᴴᴱ H (binexp M op N) (binOp₁ s) (heap W′) with reflectᴴᴱ H M s (heap W′)
reflectᴴᴱ H (binexp M op N) (binOp₁ s) (heap W′) | heap W = heap W
reflectᴴᴱ H (binexp M op N) (binOp₁ s) (heap W′) | expr W = expr (bin₁ W)
reflectᴴᴱ H (binexp M op N) (binOp₂ s) (heap W′) with reflectᴴᴱ H N s (heap W′)
reflectᴴᴱ H (binexp M op N) (binOp₂ s) (heap W′) | heap W = heap W
reflectᴴᴱ H (binexp M op N) (binOp₂ s) (heap W′) | expr W = expr (bin₂ W)

reflectᴴᴮ H B s (block W′) = reflectᴮ H B s W′
reflectᴴᴮ H (local var x ∈ T ← M ∙ B) (local s) (heap W′) with reflectᴴᴱ H M s (heap W′)
reflectᴴᴮ H (local var x ∈ T ← M ∙ B) (local s) (heap W′) | heap W = heap W
reflectᴴᴮ H (local var x ∈ T ← M ∙ B) (local s) (heap W′) | expr W = block (local₁ W)
reflectᴴᴮ H (local var x ∈ T ← M ∙ B) (subst v) (heap W′) = heap W′
reflectᴴᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) (function a p) (heap (addr b refl W′)) with b ≡ᴬ a
reflectᴴᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) (function a defn) (heap (addr a refl (FunctionDefnMismatch p))) | yes refl with heap-weakeningᴮ H C (snoc defn)
reflectᴴᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) (function a defn) (heap (addr a refl (FunctionDefnMismatch p))) | yes refl | ok r = block (FunctionDefnMismatch (λ q → p (trans q r)))
reflectᴴᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) (function a defn) (heap (addr a refl (FunctionDefnMismatch p))) | yes refl | warning W = block (function₁ W)
reflectᴴᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) (function a defn) (heap (addr a refl (function₁ W′))) | yes refl = block (function₁ (reflect-weakeningᴮ H C (snoc defn) W′))
reflectᴴᴮ H (function f ⟨ var y ∈ T ⟩∈ U is C end ∙ B) (function a p) (heap (addr b refl W′)) | no r = heap (addr b (lookup-not-allocated p r) (reflect-weakeningᴼ H _ (snoc p) W′))
reflectᴴᴮ H (return M ∙ B) (return s) (heap W′) with reflectᴴᴱ H M s (heap W′)
reflectᴴᴮ H (return M ∙ B) (return s) (heap W′) | heap W = heap W
reflectᴴᴮ H (return M ∙ B) (return s) (heap W′) | expr W = block (return W)

reflect* : ∀ H B {H′ B′} → (H ⊢ B ⟶* B′ ⊣ H′) → Warningᴴᴮ H′ (typeCheckᴴᴮ H′ ∅ B′) → Warningᴴᴮ H (typeCheckᴴᴮ H ∅ B)
reflect* H B refl W = W
reflect* H B (step s t) W = reflectᴴᴮ H B s (reflect* _ _ t W)

runtimeBinOpWarning : ∀ H {op} v → BinOpError op (valueType v) → BinOpWarning op (orNone (typeOfⱽ H v))
runtimeBinOpWarning H v (+ p) = + (λ q → p (mustBeNumber H ∅ v q))
runtimeBinOpWarning H v (- p) = - (λ q → p (mustBeNumber H ∅ v q))
runtimeBinOpWarning H v (* p) = * (λ q → p (mustBeNumber H ∅ v q))
runtimeBinOpWarning H v (/ p) = / (λ q → p (mustBeNumber H ∅ v q))
runtimeBinOpWarning H v (< p) = < (λ q → p (mustBeNumber H ∅ v q))
runtimeBinOpWarning H v (> p) = > (λ q → p (mustBeNumber H ∅ v q))
runtimeBinOpWarning H v (<= p) = <= (λ q → p (mustBeNumber H ∅ v q))
runtimeBinOpWarning H v (>= p) = >= (λ q → p (mustBeNumber H ∅ v q))
runtimeBinOpWarning H v (·· p) = ·· (λ q → p (mustBeString H ∅ v q))

runtimeWarningᴱ : ∀ H M → RuntimeErrorᴱ H M → Warningᴱ H (typeCheckᴱ H ∅ M)
runtimeWarningᴮ : ∀ H B → RuntimeErrorᴮ H B → Warningᴮ H (typeCheckᴮ H ∅ B)

runtimeWarningᴱ H (var x) UnboundVariable = UnboundVariable refl
runtimeWarningᴱ H (val (addr a)) (SEGV p) = UnallocatedAddress p
runtimeWarningᴱ H (M $ N) (FunctionMismatch v w p) with typeOf-val-not-none w
runtimeWarningᴱ H (M $ N) (FunctionMismatch v w p) | ok q = FunctionCallMismatch (λ r → p (mustBeFunction H ∅ v (λ r′ → q (trans r′ r))))
runtimeWarningᴱ H (M $ N) (FunctionMismatch v w p) | warning W = app₂ W
runtimeWarningᴱ H (M $ N) (app₁ err) = app₁ (runtimeWarningᴱ H M err)
runtimeWarningᴱ H (M $ N) (app₂ err) = app₂ (runtimeWarningᴱ H N err)
runtimeWarningᴱ H (block var b ∈ T is B end) (block err) = block₁ (runtimeWarningᴮ H B err)
runtimeWarningᴱ H (binexp M op N) (BinOpMismatch₁ v w p) = BinOpMismatch₁ (runtimeBinOpWarning H v p)
runtimeWarningᴱ H (binexp M op N) (BinOpMismatch₂ v w p) = BinOpMismatch₂ (runtimeBinOpWarning H w p)
runtimeWarningᴱ H (binexp M op N) (bin₁ err) = bin₁ (runtimeWarningᴱ H M err)
runtimeWarningᴱ H (binexp M op N) (bin₂ err) = bin₂ (runtimeWarningᴱ H N err)

runtimeWarningᴮ H (local var x ∈ T ← M ∙ B) (local err) = local₁ (runtimeWarningᴱ H M err)
runtimeWarningᴮ H (return M ∙ B) (return err) = return (runtimeWarningᴱ H M err)

wellTypedProgramsDontGoWrong : ∀ H′ B B′ → (∅ᴴ ⊢ B ⟶* B′ ⊣ H′) → (RuntimeErrorᴮ H′ B′) → Warningᴮ ∅ᴴ (typeCheckᴮ ∅ᴴ ∅ B)
wellTypedProgramsDontGoWrong H′ B B′ t err with reflect* ∅ᴴ B t (block (runtimeWarningᴮ H′ B′ err))
wellTypedProgramsDontGoWrong H′ B B′ t err | heap (addr a refl ())
wellTypedProgramsDontGoWrong H′ B B′ t err | block W = W


module ExtractFunction where
open import Data.List
open import ParseTree
open import Data.Nat
open import Data.String hiding (_++_)
open import ScopeState using (ScopeState ; ScopeEnv ; replaceID ; liftIO ; getUniqueIdentifier)
open import ScopeParseTree
open import AgdaHelperFunctions
open import Typing
open import Data.Bool
open import MatchUpNames
open import Category.Monad.State
open import Data.Product
open import Data.Maybe
open import Relation.Nullary
open import Data.Unit using (⊤ ; tt)
open import Data.Nat.Show
open import ParseTreeOperations

--TODO: actually, it is okay if the module has no name - in this case we do not need to rename it.
getIDForModule : List ParseTree -> ScopeState Identifier
getIDForModule [] = ScopeState.fail "This module seems to have no name"
getIDForModule (moduleName id range₁ ∷ p) = ScopeState.return id
getIDForModule (x ∷ xs) = getIDForModule xs

record ExtractionEnv : Set where
  constructor extEnv
  field
   stuffBeforeFunc : List ParseTree
   stuffAfterFunc : List ParseTree
   rightHandSideBuilder : Maybe (Expr -> Expr)
   extractedExpr : Maybe Expr
   holesPassed : ℕ
   functionRebuilder : Maybe (Expr -> ParseTree)
   oldFunctionName : Maybe Identifier

ExtractionState : Set -> Set
ExtractionState = StateT ExtractionEnv ScopeState

runExtractionState :
    {a : Set} -> ExtractionState a -> ExtractionEnv -> ScopeState a
runExtractionState eMonad e = do
      (result , newState) <- eMonad e
      return result
    where open RawMonadState (StateTMonadState ScopeEnv (SumMonadT IOMonad String))

liftScopeState : {a : Set} -> ScopeState a -> ExtractionState a
liftScopeState action ee = do
  a <- action
  return (a , ee)
  where open RawMonadState (StateTMonadState ScopeEnv (SumMonadT IOMonad String))

open RawMonadState (StateTMonadState ExtractionEnv (StateTMonad ScopeEnv (SumMonadT IOMonad String)))

fail : {a : Set} -> String -> ExtractionState a
fail s = liftScopeState $ ScopeState.fail s

--assuming that start < end
isInside : Range -> ℕ -> ℕ -> Bool
isInside (range lastUnaffected lastAffected) start end
  with end ≤? lastUnaffected | lastAffected ≤? suc start
... | no p | no q = true
... | p | q = false

isInIdent : Identifier -> ℕ -> ℕ -> Bool
isInIdent (identifier name isInRange scope declaration {b}{c} {c2}) start end
  with isInRange start | isInRange end
... | after | _ = false
... | _ | before = false
... | _ | _ = true

findPartInExpr : Expr -> ℕ -> ℕ -> ExtractionState Bool
findPartInExpr (numLit {value}
    {r} {c} {c2}) start end
      with isInside r start end
... | true = do
      extEnv x y f expr h g n  <- get
      put $ extEnv x y (just(λ a -> a)) (just $ numLit {value} {r} {c} {c2}) h g n
      return true
... | false = return false
findPartInExpr (ident id) start end
  with isInIdent id start end
... | false = return false
... | true = do
    extEnv x y f expr h g n <- get
    put $ extEnv x y (just(λ a -> a)) (just $ ident id) h g n
    return true
findPartInExpr (hole {t} {p} {c} {c2}) start end
    with isInside p start end
... | true = do
  extEnv x y f expr h g n  <- get
  put $ extEnv x y (just(λ a -> a)) (just $ hole {t} {p} {c} {c2}) h g n
  return true
... | false = return false
findPartInExpr (functionApp e e₁ {false} ) start end = do
    true <- findPartInExpr e₁ start end
      where false -> do
                  true <- findPartInExpr e start end
                    where false -> return false
                  -- here we want to extract some subexpression of e
                  -- so we rebuild it with rebuilder f and put it in the functionApp
                  extEnv x y (just f) expr h g n <- get
                    where _ -> fail "Got no function despite extraction"
                  put $ extEnv x y (just(λ x -> functionApp (f x) e₁ {false})) expr h g n
                  return true
    extEnv x y (just f) expr h g n <- get
      where _ -> fail "Got no function despite extraction"
    true <- findPartInExpr e start end
      where false -> do -- extract only (part of) e₁
                put $ extEnv x y (just (λ a -> functionApp e (f a) {false})) expr h g n
                return true
    -- at this point we realize we want to extract the entire
    -- functionApp
    -- Therefore, we need to extract entire e and e₁ regardless of
    -- how far into it the selection extends.
    --extEnv x y f expr h g n <- get
    put $ extEnv x y (just (λ x -> x)) (just $ functionApp e e₁ {false} ) h g n
    return true
findPartInExpr (functionApp e e₁ {true} ) start end = do
  true <- findPartInExpr e start end
    where false -> do
           true <- findPartInExpr e₁ start end
            where false -> return false
           extEnv x y (just f) expr h g n <- get
            where _ -> fail "Got no function despite extraction"
           put $ extEnv x y (just(λ x -> functionApp e (f x) {true} )) expr h g n
           return true
  extEnv x y (just f) expr h g n <- get
   where _ -> fail "Got no function despite extraction"
  namedArgument sign <- return e
   where _ -> do
          -- e is not a named argument so can be extracted by itself
          true <- findPartInExpr e₁ start end
           where false -> do
                  put $ extEnv x y (just (λ a -> functionApp (f e) e₁ {true})) expr h g n
                  return true
          put $ extEnv x y (just (λ x -> x)) (just $ functionApp e e₁ {true}) h g n
          return true
  put $ extEnv x y (just $ λ x -> x) (just $ functionApp e e₁ {true}) h g n
  return true
findPartInExpr (implicit x) start end = do
  true <- findPartInExpr x start end
    where false -> return false
  extEnv x y (just f) expr h g n <- get
    where _ -> fail "Extraction failed"
  put $ extEnv x y (just(λ a -> implicit $ f a)) expr h g n
  return true
findPartInExpr (underscore {p} {c1} {c2}) start end with isInside p start end
... | true = do
  extEnv x y f expr h g n  <- get
  put $ extEnv x y (just(λ a -> a)) (just $ underscore {p} {c1} {c2}) h g n
  return true
... | false = return false
findPartInExpr (namedArgument (typeSignature funcName funcType) {b} {bef} {aft}) start end
  with isInIdent funcName start end
-- can't extract just the name of a variable
... | true =  do
            extEnv x y f expr h g n <- get
            put $ extEnv x y (just $ λ x -> x)
              (just $ namedArgument (typeSignature funcName funcType)  {b} {bef} {aft}) h g n
            return true
... | false = do
    true <- findPartInExpr funcType start end
      where false -> return false
    extEnv x y (just f) expr h g n  <- get
      where _ -> fail "No function in state"
    put $ extEnv x y (just $ λ x -> namedArgument (typeSignature funcName $ f x) {b} {bef} {aft}) expr h g n
    return true

sameNameAndStatus : Identifier -> Identifier -> Bool
sameNameAndStatus (identifier name isInRange scope declaration {inScope1}) (identifier name₁ isInRange₁ scope₁ declaration₁ {inScope2}) = (name == name₁) ∧ (not $ inScope1 xor inScope2)

isIdInExpr : (whatToSearchFor : Identifier) -> (whereToSearch : Expr) -> Bool
isIdInExpr i (ident identifier₁) = sameNameAndStatus i identifier₁
isIdInExpr i (functionApp x x₁) = isIdInExpr i x ∨ isIdInExpr i x₁
isIdInExpr _ _ = false

countHole : ExtractionState ⊤
countHole = do
  extEnv b a func exp h g n <- get
  put $ extEnv b a func exp (suc h) g n
  return tt

mapState : {A B : Set} -> (A -> ExtractionState B) -> List A -> ExtractionState (List B)
mapState f [] = return []
mapState f (x ∷ list) = do
  x1 <- f x
  xs <- mapState f list
  return (x1 ∷ xs)

countHolesInSignature : TypeSignature -> ExtractionState ⊤

countHolesInExpr : Expr -> ExtractionState ⊤
countHolesInExpr hole = countHole
countHolesInExpr (functionApp e e₁) = do
  countHolesInExpr e
  countHolesInExpr e₁
countHolesInExpr (namedArgument arg) = countHolesInSignature arg
countHolesInExpr _ = return tt

countHolesInSignature (typeSignature funcName funcType) =
  countHolesInExpr funcType

countHolesInTree : ParseTree -> ExtractionState ⊤
countHolesInTree (signature signature₁ range₁) = countHolesInSignature signature₁
countHolesInTree (functionDefinition definitionOf params body range₁) = countHolesInExpr body
countHolesInTree (dataStructure dataName parameters indexInfo constructors range₁) = do
  mapState countHolesInSignature parameters
  mapState countHolesInSignature constructors
  countHolesInExpr indexInfo
countHolesInTree _ = return tt

findPartToExtract : List ParseTree -> ℕ -> ℕ -> ExtractionState ⊤
findPartToExtract [] start end = fail "Found nothing that can be extracted"
findPartToExtract (functionDefinition definitionOf params body (range a z) ∷ e)
      start end with (suc a) ≤? start | end ≤? z
... | yes p | yes q = do
      true <- findPartInExpr body start end
        where false -> fail "Command start and end must be in the function body"
      extEnv bef aft func exp h g n <- get
      put $ extEnv bef e func exp h (just (λ x -> functionDefinition definitionOf params x (range a z))) $ just definitionOf
      just ex <- return exp
        where nothing -> fail "Didn't get an expression to extract"
      mapState countHolesInTree bef
      return tt
findPartToExtract (p ∷ ps) start end | yes a | no b = do
    extEnv b a func exp h g n  <- get
    put $ extEnv (b ∷ʳ p) a func exp h g n
    findPartToExtract ps start end
... | p | q = fail "Command start and end not fully inside any function"
findPartToExtract (p ∷ ps) start end = do
    extEnv b a func exp h g n <- get
    put $ extEnv (b ∷ʳ p) a func exp h g n
    findPartToExtract ps start end

makeTypeFromTypes : List Expr -> ExtractionState Expr
makeTypeFromTypes [] = fail "Can't make type from nothing"
makeTypeFromTypes (x ∷ []) = return x
makeTypeFromTypes (x ∷ xs) = do
    y <- makeTypeFromTypes xs
    return $ functionApp x y {true}

makeExprFromExprs : List Expr -> ExtractionState Expr
makeExprFromExprs [] = fail "Can't make expr from nothing"
makeExprFromExprs (x ∷ []) = return x
makeExprFromExprs (x ∷ l) = do
  y <- makeExprFromExprs l
  return $ functionApp y x {false}

-- List of type signatures is environment. Contains all variables,
-- including not-in-scope. Return list is the new function's environment.
filterEnvironment : Expr -> List TypeSignature -> (extractedExp : Expr) -> ExtractionState (List TypeSignature)
filterEnvironment resultType [] varsUsed = return []
filterEnvironment resultType (typeSignature funcName funcType ∷ environment) extractedExpr = do
  filteredEnv <- filterEnvironment resultType environment extractedExpr
  let isInExtractedExpr = isIdInExpr funcName extractedExpr
  let typesToCheck = Data.List.map (λ { (typeSignature n t) -> t}) filteredEnv
  isInTypes <- mapState (findInType funcName) typesToCheck
  let isIn = or isInTypes
  if isIn ∨ isInExtractedExpr
   then return $ (typeSignature funcName funcType) ∷ filteredEnv
   else return filteredEnv
 where
  findInType : Identifier -> Expr -> ExtractionState Bool

  findInType id (namedArgument (typeSignature funcName funcType)) = findInType id funcType
  findInType id (functionApp t t₁ {true}) = do
    one <- findInType id t
    two <- findInType id t₁
    return $ one ∨ two
  findInType id expression = return $ isIdInExpr id expression

bringIdInScope : Identifier -> Identifier
bringIdInScope (identifier name isInRange scope declaration {inScope} {a} {b}) = identifier name isInRange scope declaration {true} {a}{b}

containsIdInSign : TypeSignature -> Identifier -> Bool

containsInType : Expr -> Identifier -> Bool

containsInType (namedArgument arg) i = containsIdInSign arg i
containsInType (functionApp t t₁ {true}) i = containsInType t i ∨ containsInType t₁ i
containsInType expression i = isIdInExpr i expression

containsIdInSign (typeSignature name funcType) id = sameNameAndStatus name id ∨ containsInType funcType id

isInScope : Identifier -> Bool
isInScope (identifier _ _ _ _ {isInScope}) = isInScope

bringExprInScope : Expr -> Expr
bringExprInScope (ident id) = ident $ bringIdInScope id
bringExprInScope (functionApp e e₁ {b} ) = functionApp (bringExprInScope e) (bringExprInScope e₁) {b}
bringExprInScope (implicit e) = implicit $ bringExprInScope e
bringExprInScope x = x

bringInScope : Expr -> Expr
bringSignatureInScope : TypeSignature -> TypeSignature
bringSignatureInScope (typeSignature funcName funcType) =
  typeSignature (bringIdInScope funcName) $ bringInScope funcType

bringInScope (namedArgument arg {b} {bef} {aft}) = namedArgument (bringSignatureInScope arg) {b} {bef} {aft}
bringInScope (functionApp t t₁ {true} ) = functionApp (bringInScope t) (bringInScope t₁) {true}
bringInScope expression = bringExprInScope expression
renameNotInScopeExpr : Identifier -> Identifier -> Expr -> Expr
renameNotInScopeExpr (identifier name₁ isInRange₁ scope₁ declaration₁) to (ident (identifier name isInRange scope declaration {false} {b} {a})) with name == name₁
renameNotInScopeExpr (identifier name₁ isInRange₁ scope₁ declaration₁) (identifier name₂ isInRange₂ scope₂ declaration₂) (ident (identifier name isInRange scope declaration {false} {b} {a})) | true = ident $ identifier name₂ isInRange₂ scope₂ declaration₂ {false}{b} {a}
... | false = ident $ identifier name isInRange scope declaration {false} {b} {a}
renameNotInScopeExpr from to (functionApp e e₁ {b} ) =
  functionApp (renameNotInScopeExpr from to e) (renameNotInScopeExpr from to e₁) {b}
renameNotInScopeExpr from to (implicit e) = implicit $ renameNotInScopeExpr from to e
renameNotInScopeExpr _ _ x = x

renameNotInScopeOfName : Identifier -> Identifier -> Expr -> Expr

renameNotInScopeSign : Identifier -> Identifier -> TypeSignature -> TypeSignature
renameNotInScopeSign from to (typeSignature funcName funcType) =
  typeSignature funcName $ renameNotInScopeOfName from to funcType

renameNotInScopeOfName from to (namedArgument arg {b} {bef} {aft}) = namedArgument  (renameNotInScopeSign from to arg) {b} {bef} {aft}
renameNotInScopeOfName from to (functionApp signs signs₁ {true} ) =
  functionApp (renameNotInScopeOfName from to signs) (renameNotInScopeOfName from to signs₁) {true}
renameNotInScopeOfName from to expression = renameNotInScopeExpr from to expression

-- returns list of types, which are explicit or implicit named arguments
-- and a list of expressions which is the left-hand side of the new function, i.e. idents.
signatureToType : Expr -> List TypeSignature -> ExtractionState (List Expr × List Expr)
signatureToType result [] = return $ (result ∷ []) , []
signatureToType result (typeSignature funcName funcType ∷ laterSigns) = do
  let inScopeType = bringInScope funcType
  (restOfSigns , exprs) <- signatureToType result laterSigns
  false <- return $ isInScope funcName
    where true -> do -- in this case, we plainly don't want to rename anything
                    let newSign = namedArgument (typeSignature funcName funcType) {true} {[]}{[]}
                    return $ newSign ∷  restOfSigns , ident funcName ∷ exprs
  -- Do we need to rename the current variable?
  true <- return $ or $ Data.List.map (λ x -> containsIdInSign x $ bringIdInScope funcName) laterSigns
    where false -> do
              let newSign = namedArgument (typeSignature funcName funcType) {false} {[]}{[]}
              return $ newSign ∷  restOfSigns , exprs
  liftScopeState $ liftIO $ output "Need to rename a variable"
  newName <- liftScopeState getUniqueIdentifier
  let renamedSigns = Data.List.map (renameNotInScopeOfName funcName newName) restOfSigns
  return $ namedArgument (typeSignature newName inScopeType) {false} {[]}{[]} ∷ renamedSigns , exprs

placeInRightPlace : Identifier -> (placeOverTypeSignature : Bool) -> ParseTree -> ParseTree -> List ParseTree -> List ParseTree
placeInRightPlace oldFunctionName _ newsign newdef [] = newsign ∷ newdef ∷ []
placeInRightPlace oldFunctionName false newsign newdef (functionDefinition definitionOf params body range₁ ∷ program) with sameId oldFunctionName definitionOf
...| false = functionDefinition definitionOf params body range₁ ∷ placeInRightPlace oldFunctionName false newsign newdef program
... | true = newsign ∷ newdef ∷ functionDefinition definitionOf params body range₁ ∷ program
placeInRightPlace oldFunctionName true newsign newdef (signature (typeSignature funcName funcType) range₁ ∷ program) with sameId oldFunctionName funcName
... | false = signature (typeSignature funcName funcType) range₁ ∷ placeInRightPlace oldFunctionName true newsign newdef program
... | true = newsign ∷ newdef ∷  signature (typeSignature funcName funcType) range₁ ∷ program
placeInRightPlace x y z a (p ∷ program) = p ∷ placeInRightPlace x y z a program

doExtraction : List ParseTree -> ℕ -> ℕ -> String -> ExtractionState (List ParseTree)
doExtraction program startPoint endPoint filename = do
  scoped <- liftScopeState $ scopeParseTreeList program
  -- TODO: Assuming that the module only has a simple name.
  -- Otherwise, need to calculate the right name.
  identifier name _ _ declaration <- liftScopeState $ getIDForModule scoped
  liftScopeState $ replaceID declaration "RefactorAgdaTemporaryFile"
  renamedInputProgram <- liftScopeState $ matchUpNames scoped
  findPartToExtract renamedInputProgram startPoint endPoint
  extEnv b a (just expBuilder) (just extractedExp) h (just functionBuilder) (just oldFunctionName)  <- get
    where _ -> fail "An error in doExtraction"
  let programWithNewHole = b ++
        ((functionBuilder $ expBuilder $ hole {""} {range 0 0} {[]} {[]})∷ a)
  (resultTypeNewFunc ∷ []) <- liftScopeState $ liftIO $ getTypes
                              programWithNewHole h
                                (extractedExp ∷ []) filename
            where _ -> fail "Something happened in InteractWithAgda"
  environment <- liftScopeState $ liftIO $ getEnvironment programWithNewHole h filename
  newFuncName <- liftScopeState $ getUniqueIdentifier
  newFuncEnv <- filterEnvironment resultTypeNewFunc environment extractedExp
  (newFuncSignParts , newFuncArgNames) <- signatureToType resultTypeNewFunc newFuncEnv
  newFuncType <- makeTypeFromTypes $ newFuncSignParts
  let newFuncSignature = signature (typeSignature newFuncName newFuncType) (range 0 0)
  let newFuncDefinition = functionDefinition newFuncName newFuncArgNames extractedExp (range 0 0)
  replacingExpr <- makeExprFromExprs $ reverse $ ident newFuncName ∷ newFuncArgNames
  let oldFunction = functionBuilder $ expBuilder $ replacingExpr
  let placeBelowTypeSignature = isIdInExpr oldFunctionName extractedExp
  let completeCode = placeInRightPlace oldFunctionName (not placeBelowTypeSignature) newFuncSignature newFuncDefinition b ++
        (oldFunction ∷ a)
  scopeCompleted <- liftScopeState $ scopeParseTreeList completeCode
  identifier _ _ _ d <- liftScopeState $ getIDForModule scopeCompleted
  liftScopeState $ replaceID d name
  liftScopeState $ matchUpNames scopeCompleted

extract : List ParseTree -> ℕ -> ℕ -> String -> ScopeState (List ParseTree)
extract p s e f = runExtractionState (doExtraction p s e f) $ extEnv [] [] nothing nothing 0 nothing nothing


module ctxt-types where

open import lib
open import cedille-types
open import general-util
open import syntax-util

location : Set
location = string × posinfo -- file path and starting position in the file

-- file path and starting / ending position in file
span-location = string × posinfo × posinfo

-- missing locations
missing-location : location
missing-location = ("missing" , "missing")

missing-span-location : span-location
missing-span-location = ("missing" , "missing" , "missing")

{- we will generally keep classifiers of variables in hnf in the ctxt, although
   we will not necessarily unfold recursive type definitions. -}

defScope : Set
defScope = 𝔹

localScope : defScope
localScope = tt

globalScope : defScope
globalScope = ff

defParams : Set
defParams = maybe params

data ctxt-info : Set where
  -- for defining a datatype
  datatype-def : params → kind → ctxt-info

  -- for defining a datatype constructor
  const-def : type → ctxt-info

  -- for declaring a variable to have a given type (with no definition)
  term-decl : type → ctxt-info

  -- for defining a variable to equal a term with a given type
  term-def : defParams → opacity → term → type → ctxt-info

  -- for untyped term definitions
  term-udef : defParams → opacity → term → ctxt-info

  -- for declaring a variable to have a given kind (with no definition)
  type-decl : kind → ctxt-info

  -- for defining a variable to equal a type with a given kind
  type-def : defParams → opacity → type → kind → ctxt-info

  -- for defining a variable to equal a kind
  kind-def : params → kind → ctxt-info

  -- to rename a variable at any level to another
  rename-def : var → ctxt-info

  -- representing a declaration of a variable with no other information about it
  var-decl : ctxt-info

sym-info : Set
sym-info = ctxt-info × location

-- module filename, name, parameters, and qualifying substitution
mod-info : Set
mod-info = string × string × params × qualif

-- datatypes info
datatype-info : Set
datatype-info = defDatatype

is-term-level : ctxt-info → 𝔹
is-term-level (term-decl _) = tt
is-term-level (term-def _ _ _ _) = tt
is-term-level (term-udef _ _ _) = tt
is-term-level (const-def _ ) = tt
is-term-level _ = ff

data ctxt : Set where
  mk-ctxt : (mod : mod-info) →                     -- current module
            (syms : trie (string × 𝕃 string) × trie string × trie params × trie ℕ × Σ ℕ (𝕍 string)) →    -- map each filename to its module name and the symbols declared in that file, map each module name to its filename and params, and file ID's for use in to-string.agda
            (i : trie sym-info) →                  -- map symbols (from Cedille files) to their ctxt-info and location
            (sym-occurrences : trie (𝕃 (var × posinfo × string))) →  -- map symbols to a list of definitions they occur in (and relevant file info)
            (datatypes-info : trie datatype-info) →
            ctxt

ctxt-binds-var : ctxt → var → 𝔹
ctxt-binds-var (mk-ctxt (_ , _ , _ , q) _ i _ _) x = trie-contains q x || trie-contains i x

ctxt-var-decl : var → ctxt → ctxt
ctxt-var-decl v (mk-ctxt (fn , mn , ps , q) syms i symb-occs d) =
  mk-ctxt (fn , mn , ps , (trie-insert q v (v , ArgsNil))) syms (trie-insert i v (var-decl , "missing" , "missing")) symb-occs d

ctxt-var-decl-loc : posinfo → var → ctxt → ctxt
ctxt-var-decl-loc pi v (mk-ctxt (fn , mn , ps , q) syms i symb-occs d) =
  mk-ctxt (fn , mn , ps , (trie-insert q v (v , ArgsNil))) syms (trie-insert i v (var-decl , fn , pi)) symb-occs d

qualif-var : ctxt → var → var
qualif-var (mk-ctxt (_ , _ , _ , q) _ _ _ _) v with trie-lookup q v
...| just (v' , _) = v'
...| nothing = v

start-modname : start → string
start-modname (File _ _ _ _ mn _ _ _) = mn

ctxt-get-current-filename : ctxt → string
ctxt-get-current-filename (mk-ctxt (fn , _) _ _ _ _) = fn

ctxt-get-current-mod : ctxt → mod-info
ctxt-get-current-mod (mk-ctxt m _ _ _ _) = m

ctxt-get-current-modname : ctxt → string
ctxt-get-current-modname (mk-ctxt (_ , mn , _ , _) _ _ _ _) = mn

ctxt-get-current-params : ctxt → params
ctxt-get-current-params (mk-ctxt (_ , _ , ps , _) _ _ _ _) = ps

ctxt-get-symbol-occurrences : ctxt → trie (𝕃 (var × posinfo × string))
ctxt-get-symbol-occurrences (mk-ctxt _ _ _ symb-occs _) = symb-occs

ctxt-set-symbol-occurrences : ctxt → trie (𝕃 (var × posinfo × string)) → ctxt
ctxt-set-symbol-occurrences (mk-ctxt fn syms i symb-occs d) new-symb-occs = mk-ctxt fn syms i new-symb-occs d