open import cedille-types
import spans
open import ctxt
import cedille-options
open import general-util

module type-inf
  (options : cedille-options.options)
  {mF : Set → Set}
  ⦃ _ : monad mF ⦄
  (check-term : ctxt → ex-tm → (T? : maybe type) →
                spans.spanM options {mF} (spans.check-ret options {mF} T? term))
  (check-type : ctxt → ex-tp → (k? : maybe kind) →
                spans.spanM options {mF} (spans.check-ret options {mF} k? type))
  where

open import spans options {mF}
open import rename
open import syntax-util
open import type-util
open import meta-vars options {mF}
open import resugar
open import subst
open import conversion
open import free-vars
open import constants

record spine-data : Set where
  constructor mk-spine-data
  field
    spine-mvars : meta-vars
    spine-type : decortype
    spine-locale : ℕ
    spine-elab : meta-vars → term

check-term-spine-elim : ctxt → spine-data → term × type
check-term-spine-elim Γ (mk-spine-data Xs dt locl f~) =
  f~ Xs , meta-vars-subst-type' ff Γ Xs (decortype-to-type dt)
--  elim-pair (maybe-else' (meta-vars-to-args Xs) ([] , Hole pi-gen) f~) recompose-apps ,
--  meta-vars-subst-type' ff Γ Xs (decortype-to-type dt)

check-term-spine : ctxt → ex-tm → (m : prototype) → 𝔹 → spanM (maybe spine-data)

check-term-spine-return : meta-vars → decortype → ℕ → (meta-vars → term) → spanM (maybe spine-data)
check-term-spine-return Xs dt locl f~ = return (just (mk-spine-data Xs dt locl f~))

-- a flag indicating how aggresively we should be unfolding during matching.
-- "both" is the backtracking flag. We will attempt "both" matches, which means
-- first matching without unfolding, then if that fails unfolding the type once
-- and continue matching the subexpresions with "both"
data match-unfolding-state : Set where
  match-unfolding-both match-unfolding-approx match-unfolding-hnf : match-unfolding-state

-- main matching definitions
-- --------------------------------------------------

-- NOTE: these functions don't actually ever emit spans
match-types : ctxt → meta-vars → local-vars → match-unfolding-state → (tpₓ tp : type) → spanM $ match-error-t meta-vars
match-kinds : ctxt → meta-vars → local-vars → match-unfolding-state → (kₓ k : kind) → spanM $ match-error-t meta-vars
match-tpkds : ctxt → meta-vars → local-vars → match-unfolding-state → (tkₓ tk : tpkd) → spanM $ match-error-t meta-vars

record match-prototype-data : Set where
  constructor mk-match-prototype-data
  field
    match-proto-mvars : meta-vars
    match-proto-dectp : decortype
    match-proto-error : 𝔹
open match-prototype-data
match-prototype : ctxt → (Xs : meta-vars) (is-hnf : 𝔹) (tp : type) (pt : prototype) → spanM match-prototype-data

-- substitutions used during matching
-- --------------------------------------------------

-- These have to be in the spanM monad because substitution can unlock a `stuck`
-- decoration, causing another round of prototype matching (which invokes type matching)

substh-decortype : ctxt → renamectxt → trie (Σi exprd ⟦_⟧) → decortype → spanM decortype
substh-decortype Γ ρ σ (decor-type tp) = return $ decor-type (substh Γ ρ σ tp)
substh-decortype Γ ρ σ (decor-arrow e? dom cod) =
  substh-decortype Γ ρ σ cod
  >>= λ cod → return $ decor-arrow e? (substh Γ ρ σ dom) cod
substh-decortype Γ ρ σ (decor-decor e? x tk sol dt) =
  let x' = subst-rename-var-if Γ ρ x σ (decortype-to-type dt)
      Γ' = ctxt-var-decl x' Γ
      ρ' = renamectxt-insert ρ x x'
  in substh-decortype Γ' ρ' σ dt
  >>= λ dt' → return $ decor-decor e? x' (substh Γ ρ σ -tk tk) (substh-meta-var-sort Γ ρ σ sol) dt'
substh-decortype Γ ρ σ (decor-stuck tp pt) =
  match-prototype Γ meta-vars-empty ff (substh Γ ρ σ tp) pt
  -- NOTE: its an invariant that if you start with no meta-variables,
  -- prototype matching produces no meta-variables as output
  >>= λ ret → return (match-proto-dectp ret)

substh-decortype Γ ρ σ (decor-error tp pt) =
  return $ decor-error (substh Γ ρ σ tp) pt

subst-decortype : {ed : exprd} → ctxt → ⟦ ed ⟧ → var → decortype → spanM decortype
subst-decortype Γ s x dt = substh-decortype Γ empty-renamectxt (trie-single x (, s)) dt

meta-vars-subst-decortype' : (unfold : 𝔹) → ctxt → meta-vars → decortype → spanM decortype
meta-vars-subst-decortype' uf Γ Xs dt =
  substh-decortype Γ empty-renamectxt (meta-vars-get-sub Xs) dt
  >>= λ dt' → return $
    if uf then hnf-decortype Γ unfold-head-elab dt' tt else dt'

meta-vars-subst-decortype : ctxt → meta-vars → decortype → spanM decortype
meta-vars-subst-decortype = meta-vars-subst-decortype' tt

-- unfolding a decorated type to reveal a term / type abstraction
-- --------------------------------------------------

{-# TERMINATING #-}
meta-vars-peel' : ctxt → span-location → meta-vars → decortype → spanM (𝕃 meta-var × decortype)
meta-vars-peel' Γ sl Xs (decor-decor e? x _ (meta-var-tp k mtp) dt) =
  let Y   = meta-var-fresh-tp Xs x sl (k , mtp)
      Xs' = meta-vars-add Xs Y
  in subst-decortype Γ (meta-var-to-type-unsafe Y) x dt
  >>= λ dt' → meta-vars-peel' Γ sl Xs' dt'
  >>= λ ret → let Ys = fst ret ; rdt = snd ret
  in return $ Y :: Ys , rdt
meta-vars-peel' Γ sl Xs dt@(decor-decor e? x _ (meta-var-tm _ _) _) = return $ [] , dt
meta-vars-peel' Γ sl Xs dt@(decor-arrow _ _ _) = return $ [] , dt
-- NOTE: vv The clause below will later generate a type error vv
meta-vars-peel' Γ sl Xs dt@(decor-stuck _ _) = return $ [] , dt
-- NOTE: vv The clause below is an internal error, if reached vv
meta-vars-peel' Γ sl Xs dt@(decor-type _) = return $ [] , dt
meta-vars-peel' Γ sl Xs dt@(decor-error _ _) = return $ [] , dt

meta-vars-unfold-tmapp' : ctxt → span-location → meta-vars → decortype → spanM (𝕃 meta-var × is-tmabsd?)
meta-vars-unfold-tmapp' Γ sl Xs dt =
  meta-vars-subst-decortype Γ Xs dt
  >>= λ dt' → meta-vars-peel' Γ sl Xs dt'
  >>= λ where
    (Ys , dt'@(decor-arrow e? dom cod)) →
      return $ Ys , yes-tmabsd dt' e? ignored-var dom ff cod
    (Ys , dt'@(decor-decor e? x _ (meta-var-tm dom _) cod)) →
      return $ Ys , yes-tmabsd dt' e? x dom (is-free-in x (decortype-to-type cod)) cod
    (Ys , dt@(decor-decor _ _ _ (meta-var-tp _ _) _)) →
      return $ Ys , not-tmabsd dt
-- NOTE: vv this is a type error vv
    (Ys , dt@(decor-stuck _ _)) →
      return $ Ys , not-tmabsd dt
-- NOTE: vv this is an internal error, if reached vv
    (Ys , dt@(decor-type _)) →
      return $ Ys , not-tmabsd dt
    (Ys , dt@(decor-error _ _)) →
      return $ Ys , not-tmabsd dt

meta-vars-unfold-tpapp' : ctxt → meta-vars → decortype → spanM is-tpabsd?
meta-vars-unfold-tpapp' Γ Xs dt =
  meta-vars-subst-decortype Γ Xs dt
  >>= λ where
   (dt″@(decor-decor e? x _ (meta-var-tp k mtp) dt')) →
    return $ yes-tpabsd dt″ e? x k (flip maybe-map mtp meta-var-sol.sol) dt'
   (dt″@(decor-decor _ _ _ (meta-var-tm _ _) _)) →
    return $ not-tpabsd dt″
   (dt″@(decor-arrow _ _ _)) → return $ not-tpabsd dt″
   (dt″@(decor-stuck _ _)) → return $ not-tpabsd dt″
   (dt″@(decor-type _)) → return $ not-tpabsd dt″
   (dt″@(decor-error _ _)) → return $ not-tpabsd dt″

-- errors
-- --------------------------------------------------

-- general type errors for applications
module check-term-app-tm-errors
  {A : Set} (t₁ t₂ : ex-tm) (htp : type) (Xs : meta-vars) (is-locale : 𝔹) (m : checking-mode) (Γ : ctxt)
  where

  inapplicable : erased? → decortype → prototype → spanM (maybe A)
  inapplicable e? dt pt =
    spanM-add
      (App-span is-locale (term-start-pos t₁) (term-end-pos t₂) m
        (head-type Γ (meta-vars-subst-type Γ Xs htp)
          -- :: decortype-data Γ dt
          -- :: prototype-data Γ pt
          :: meta-vars-data-all Γ Xs)
        (just $ "The type of the head does not allow the head to be applied to "
         ^ h e? ^ " argument"))
    >> return nothing
    where h : erased? → string
          h Erased = "an erased term"
          h NotErased = "a term"

  bad-erasure : erased? → spanM (maybe A)
  bad-erasure e? =
    spanM-add
      (App-span is-locale (term-start-pos t₁) (term-end-pos t₂) m
        (head-type Γ (meta-vars-subst-type Γ Xs htp) :: meta-vars-data-all Γ Xs)
        (just (msg e?)))
    >> return nothing
    where
    msg : erased? → string
    msg Erased =
      "The type computed for the head requires an explicit (non-erased) argument,"
      ^ " but the application is marked as erased"
    msg NotErased =
      "The type computed for the head requires an implicit (erased) argument,"
      ^ " but the application is marked as not erased"

  unmatchable : (tpₓ tp : type) (msg : string) → 𝕃 tagged-val → spanM (maybe A)
  unmatchable tpₓ tp msg tvs =
    spanM-add
      (App-span is-locale (term-start-pos t₁) (term-end-pos t₂) m
        (arg-exp-type Γ tpₓ :: arg-type Γ tp :: tvs ++ meta-vars-data-all Γ Xs)
        (just msg))
    >> return nothing

  unsolved-meta-vars : type → 𝕃 tagged-val → spanM (maybe A)
  unsolved-meta-vars tp tvs =
    spanM-add
      (App-span tt (term-start-pos t₁) (term-end-pos t₂) m
        (type-data Γ tp :: meta-vars-data-all Γ Xs ++ tvs)
        (just "There are unsolved meta-variables in this maximal application"))
    >> return nothing

module check-term-app-tp-errors
  {A : Set} (t : ex-tm) (tp : ex-tp) (htp : type) (Xs : meta-vars) (m : checking-mode) (Γ : ctxt)
  where

  inapplicable : decortype → spanM (maybe A)
  inapplicable dt =
    spanM-add
      (AppTp-span tt (term-start-pos t) (type-end-pos tp) synthesizing
        (head-type Γ (meta-vars-subst-type Γ Xs htp)
          -- :: decortype-data Γ dt
          :: meta-vars-data-all Γ Xs)
        (just "The type of the head does not allow the head to be applied to a type argument"))
    >> return nothing

  ctai-disagree : (ctai-sol : type) → spanM (maybe A)
  ctai-disagree ctai-sol =
    spanM-add (AppTp-span tt (term-start-pos t) (type-end-pos tp) m
      (head-type Γ (meta-vars-subst-type Γ Xs htp)
        :: contextual-type-argument Γ ctai-sol
        :: meta-vars-data-all Γ Xs)
      (just "The given and contextually inferred type argument differ"))
    >> return nothing

-- meta-variable locality
-- --------------------------------------------------

-- for debugging -- prepend to the tvs returned by check-spine-locality if you're having trouble
private
  locale-tag : ℕ → tagged-val
  locale-tag n = "locale n" , [[ ℕ-to-string n ]] , []

private
  is-locale : (max : 𝔹) → (locl : maybe ℕ) → 𝔹
  is-locale max locl = max || maybe-else' locl ff iszero

check-spine-locality : ctxt → meta-vars → type → (max : 𝔹) → (locl : ℕ)
                       → spanM (maybe (meta-vars × ℕ × 𝔹))
check-spine-locality Γ Xs tp max locl =
  let new-locl  = if iszero locl then num-arrows-in-type Γ tp else locl
      new-Xs    = if iszero locl then meta-vars-empty else Xs
      left-locl = is-locale max (just locl)
  in if left-locl && (~ meta-vars-solved? Xs)
        then return nothing
     else return (just (new-Xs , new-locl , left-locl))

-- main definition
--------------------------------------------------

data check-term-app-ret : Set where
  check-term-app-return : (t~ : term) (Xs : meta-vars) (cod : decortype) (arg-mode : checking-mode) → (tvs : 𝕃 tagged-val) → check-term-app-ret

check-term-app : ctxt → (Xs : meta-vars) (Ys : 𝕃 meta-var) → (t₁ t₂ : ex-tm) → is-tmabsd → 𝔹 → spanM (maybe check-term-app-ret)

check-term-spine Γ t'@(ExApp t₁ e? t₂) pt max =
  -- 1) type the applicand, extending the prototype
    let pt' = proto-arrow e? pt in
    check-term-spine Γ t₁ pt' ff
      on-fail handleApplicandTypeError
  -- 2) make sure the applicand type reveals an arrow (term abstraction)
  >>=m λ ret → let mk-spine-data Xs dt locl fₕ~ = ret in
    -- the meta-vars need to know the span they were introduced in
    let sloc = span-loc $ ctxt.fn Γ in
    -- see if the decorated type of the head `dt` reveals an arrow
    meta-vars-unfold-tmapp' Γ sloc Xs dt
  >>=c λ Ys tm-arrow? →
    return tm-arrow? on-fail (λ _ → genInapplicableError Xs dt pt' locl)
    -- if so, get the (plain, undecorated) type of the head `htp`
  >>=s λ arr → let htp = decortype-to-type ∘ is-tmabsd-dt $ arr in
  -- 3) make sure erasures of the applicand type + syntax of application match
    checkErasuresMatch e? (is-tmabsd-e? arr) htp Xs locl
  -- 4) type the application, filling in missing type arguments with meta-variables
  >>=m λ _ → check-term-app Γ Xs Ys t₁ t₂ arr (islocl locl)
  -- 5) check no unsolved mvars, if the application is maximal (or a locality)
  >>=m λ {(check-term-app-return t₂~ Xs' rtp' arg-mode tvs) →
    let rtp = decortype-to-type rtp' in
    checkLocality Γ Xs' htp rtp max (pred locl) tvs
  >>=m uncurry₂ λ Xs'' locl' is-loc →
  -- 6) generate span
    genAppSpan Γ Xs Xs' Ys pt rtp is-loc tvs
  >> check-term-spine-return Xs'' rtp' locl'
  -- 7) fill in solutions to meta-vars introduced here and return the rest
    λ sols →
      let sols = if max then Xs' else sols
--          num-sols-here = length Ys
--          sols-here = take num-sols-here sols
--          sols-rest = drop num-sols-here sols
--          as = maybe-else' (meta-vars-to-args (meta-vars-from-list sols-here)) [] id
--          tₕ~ = recompose-apps as tₕₓ~
          tₕ~ = foldl (λ X t → maybe-else' (meta-vars-lookup sols (meta-var.name X)) t
                         λ {(meta-var-mk X' (meta-var-tp k T?) _) →
                              maybe-else' T? t (AppTp t ∘ meta-var-sol.sol);
                            (meta-var-mk X' (meta-var-tm T t?) _) →
                              maybe-else' t? t (AppEr t ∘ meta-var-sol.sol)})
                      (fₕ~ sols) Ys
          app = if e? then AppEr else App in
      app tₕ~ t₂~
  }

  where
  mode = prototype-to-checking pt

  expected-type-if-pt : ctxt → prototype → 𝕃 tagged-val
  expected-type-if-pt Γ pt = case pt of λ where
    (proto-maybe mt) → maybe-else [] (λ tp → [ expected-type Γ tp ]) mt
    (proto-arrow _ _) → []

  span-loc : (fn : string) → span-location
  span-loc fn = fn , term-start-pos t₁ , term-end-pos t₂

  islocl : ℕ → 𝔹
  islocl locl = is-locale max (just $ pred locl)

  handleApplicandTypeError : spanM (maybe _)
  handleApplicandTypeError =
      spanM-add (App-span max (term-start-pos t₁) (term-end-pos t₂) mode (expected-type-if-pt Γ pt) nothing)
    >> check-term Γ t₂ nothing
    >>= (const $ return nothing)

  genInapplicableError : meta-vars → decortype → prototype → (locl : ℕ) → spanM (maybe _)
  genInapplicableError Xs dt pt locl =
    check-term-app-tm-errors.inapplicable
      t₁ t₂ (decortype-to-type dt) Xs (islocl locl) mode Γ e? dt (proto-arrow e? pt)

  checkErasuresMatch : (e?₁ e?₂ : erased?) → type → meta-vars → (locl : ℕ) → spanM (maybe ⊤)
  checkErasuresMatch e?₁ e?₂ htp Xs locl =
    if e?₁ xor e?₂
      then check-term-app-tm-errors.bad-erasure t₁ t₂ htp Xs (islocl locl) mode Γ e?₁
    else (return ∘ just $ triv)

  checkLocality : ctxt → meta-vars → (htp rtp : type) → (max : 𝔹) (locl : ℕ) → 𝕃 tagged-val → spanM ∘ maybe $ _
  checkLocality Γ Xs htp rtp max locl tvs =
    check-spine-locality Γ Xs rtp max locl
      on-fail check-term-app-tm-errors.unsolved-meta-vars
        t₁ t₂ htp Xs (islocl locl) mode Γ rtp tvs
    >>=m (return ∘ just)

  genAppSpan : ctxt → (Xs Xs' : meta-vars) → (Ys : 𝕃 meta-var) → prototype → type → (is-locl : 𝔹) → 𝕃 tagged-val → spanM ⊤
  genAppSpan Γ Xs Xs' Ys pt rtp is-loc tvs =
    spanM-add $ elim-pair
      (meta-vars-check-type-mismatch-if (prototype-to-maybe pt) Γ "synthesized" meta-vars-empty rtp)
      λ tvs' → App-span is-loc (term-start-pos t₁) (term-end-pos t₂) mode
        (tvs' ++ meta-vars-intro-data Γ (meta-vars-from-list Ys)
          ++ meta-vars-sol-data Γ Xs Xs' ++ tvs)

check-term-spine Γ t'@(ExAppTp t tp) pt max =
  -- 1) type the applicand `t`
    check-term-spine Γ t pt max
      on-fail handleApplicandTypeError
  -- 1a) Xs: spine meta-variables; dt: decorated type of t ; htp: plain type of `t`
  >>=m λ ret → let mk-spine-data Xs dt locl fₕ~ = ret ; htp = decortype-to-type dt in
  -- 2) make sure it reveals a type abstraction
    meta-vars-unfold-tpapp' Γ Xs dt
     on-fail (λ _ → genInapplicableError Xs htp dt)
  -- 3) ensure the type argument has the expected kind,
  --    but don't compare with the contextually infered type argument (for now)
  >>=s λ ret → let mk-tpabsd dt' e? x k sol rdt = ret in
    check-type Γ tp (just (meta-vars-subst-kind Γ Xs k))
  -- 4) produce the result type of the application
  >>= λ tp~ → subst-decortype-if Γ tp~ Xs x k sol rdt
  >>= λ ret → let Xs = fst ret ; rdt = snd ret ; rtp = decortype-to-type rdt in
  -- 5) generate span data
    genAppTpSpan Γ Xs pt rtp htp
  >> check-term-spine-return Xs rdt locl
  -- 7) fill in solutions to meta-vars introduced here and return the rest
    λ sols → AppTp (fₕ~ sols) tp~
    --(map-snd (λ tₕ~ → AppE tₕ~ (Ttp tp~)) ∘ fₕ~)

  where
  mode = prototype-to-checking pt

  span-loc : ctxt → span-location
  span-loc Γ = (ctxt.fn Γ) , term-start-pos t , type-end-pos tp

  handleApplicandTypeError : spanM ∘ maybe $ spine-data
  handleApplicandTypeError =
      [- AppTp-span tt (term-start-pos t) (type-end-pos tp) synthesizing [] nothing -]
    check-type Γ tp nothing >>= λ _ → return nothing

  genInapplicableError : meta-vars → type → decortype → spanM ∘ maybe $ spine-data
  genInapplicableError Xs htp dt =
    check-term-app-tp-errors.inapplicable t tp htp Xs mode Γ dt

  subst-decortype-if : ctxt → type → meta-vars → var → kind → maybe type → decortype → spanM (meta-vars × decortype)
  subst-decortype-if Γ tp Xs x k sol rdt =
    if ~ is-hole tp
      then subst-decortype Γ tp x rdt >>= (λ res → return (Xs , res))
      else let sol = maybe-map (λ t → mk-meta-var-sol t checking) sol
               Y   = meta-var-fresh-tp Xs x (span-loc Γ) (k , sol)
               Xs' = meta-vars-add Xs Y
           in subst-decortype Γ (meta-var-to-type-unsafe Y) x rdt >>= λ rdt' → return (Xs' , rdt')

  genAppTpSpan : ctxt → meta-vars → prototype → (ret-tp head-tp : type) → spanM ⊤
  genAppTpSpan Γ Xs pt ret-tp head-tp = spanM-add ∘ elim-pair
    -- check for a type mismatch, if there even is an expected type
    (meta-vars-check-type-mismatch-if (prototype-to-maybe pt) Γ "synthesizing" Xs ret-tp) $
    -- then take the generated 𝕃 tagged-val and add to the span
    λ tvs → AppTp-span ff (term-start-pos t) (type-end-pos tp) mode $
              tvs {- ++ [ head-type Γ head-tp ] -}
              ++ meta-vars-data-all Γ Xs
              {- ++ (prototype-data Γ tp :: [ decortype-data Γ dt ]) -}

check-term-spine Γ (ExParens _ t _) pt max =
  check-term-spine Γ t pt max

check-term-spine Γ t pt max =
  check-term Γ t nothing >>=c λ t~ htp →
  let locl = num-arrows-in-type Γ htp
  in match-prototype Γ meta-vars-empty ff htp pt
  -- NOTE: it is an invariant that the variables solved in the
  -- solution set of the fst of this are a subset of the variables given
  -- to match-* -- that is, for (σ , W) = match-prototype ...
  -- we have dom(σ) = ∅
  >>= λ ret → let dt = match-proto-dectp ret in
  check-term-spine-return meta-vars-empty dt locl λ _ → t~

-- check-term-app
-- --------------------------------------------------
--
-- If `dom` has unsolved meta-vars in it, synthesize argument t₂ and try to solve for them.
-- Otherwise, check t₂ against a fully known expected type
check-term-app Γ Xs Zs t₁ t₂ (mk-tmabsd dt e? x dom occurs cod) is-locl =
   let Xs' = meta-vars-add* Xs Zs ; tp = decortype-to-type dt in
  -- 1) either synth or check arg type, depending on available info
  --    checking "exits early", as well as failure
  checkArgWithMetas Xs' tp (genAppRetType Γ)
    on-fail return
  -- 2) match *synthesized* type with expected (partial) type
  >>=s uncurry₂ λ rdt t₂~ atp → match-types Γ Xs' empty-trie match-unfolding-both dom atp
  >>= (handleMatchResult Xs' t₂~ atp tp rdt)

  where
  mode = synthesizing

  genAppRetType : ctxt → term → spanM decortype
  genAppRetType Γ t₂~ = if occurs then subst-decortype Γ t₂~ x cod else return cod

  genAppRetTypeHole : ctxt → spanM decortype
  genAppRetTypeHole Γ = if occurs then subst-decortype Γ (Hole posinfo-gen) x cod else return cod

  checkArgWithMetas : meta-vars → type → (term → spanM decortype) → spanM (maybe check-term-app-ret ∨ (decortype × term × type))
  checkArgWithMetas Xs' tp rdt-f =
    -- check arg against fully known type
    if ~ meta-vars-are-free-in-type Xs' dom
      then (check-term Γ t₂ (just dom) >>= λ t₂~ →
            rdt-f t₂~ >>= λ rdt →
            return (inj₁ (just $ check-term-app-return t₂~ Xs' rdt mode [])))
    -- synthesize type for the argument
      else (check-term Γ t₂ nothing >>=c λ t tp →
            rdt-f t >>= λ rdt →
            return (inj₂ $ rdt , t , tp))

  handleMatchResult : meta-vars → (t₂~ : term) → (atp tp : type) → decortype → match-error-t meta-vars → spanM ∘ maybe $ check-term-app-ret
  handleMatchResult Xs' t₂~ atp tp rdt (match-error (msg , tvs)) =
    check-term-app-tm-errors.unmatchable
      t₁ t₂ tp Xs' is-locl mode Γ dom atp msg tvs
  handleMatchResult Xs' t₂~ atp tp rdt (match-ok Xs) =
      meta-vars-subst-decortype' ff Γ Xs rdt
    >>= λ rdt → return ∘ just $ check-term-app-return t₂~ Xs rdt mode []

match-unfolding-next : match-unfolding-state → match-unfolding-state
match-unfolding-next match-unfolding-both = match-unfolding-both
match-unfolding-next match-unfolding-approx = match-unfolding-approx
match-unfolding-next match-unfolding-hnf = match-unfolding-both

module m-err = meta-vars-match-errors

check-type-for-match : ctxt → type → spanM $ match-error-t kind
check-type-for-match Γ tp =
  (with-clear-error $
      check-type (qualified-ctxt Γ) (resugar tp) nothing >>=c λ _ k → return (match-ok $ k)) >>=spand return

-- match-types
-- --------------------------------------------------

match-types-ok : meta-vars → spanM $ match-error-t meta-vars
match-types-ok = return ∘ match-ok

match-types-error : match-error-data → spanM $ match-error-t meta-vars
match-types-error = return ∘ match-error

match-types Γ Xs Ls match-unfolding-both tpₓ tp =
    match-types Γ Xs Ls match-unfolding-approx tpₓ tp
  >>= λ where
    (match-ok Xs) → match-types-ok Xs
    (match-error msg) →
      match-types Γ Xs Ls match-unfolding-hnf
        (hnf Γ unfold-head-elab tpₓ)
        (hnf Γ unfold-head-elab tp)

match-types Γ Xs Ls unf tpₓ@(TpVar x) tp =
  -- check that x is a meta-var
  maybe-else' (meta-vars-lookup-with-kind Xs x)
    -- if not, make sure the two variables are the same
    -- TODO: above assumes no term meta-variables
    (return (err⊎-guard (~ conv-type Γ tpₓ tp) m-err.e-match-failure
            >> match-ok Xs))
  -- scope check the solution
  λ ret → let X = fst ret ; kₓ = snd ret in
  if are-free-in Ls tp then
    match-types-error $ m-err.e-meta-scope Γ tpₓ tp
  else (check-type-for-match Γ tp
  >>=s λ k → match-kinds Γ Xs empty-trie match-unfolding-both kₓ k
    on-fail (λ _ → return ∘ match-error $ m-err.e-bad-sol-kind Γ x tp)
  >>=s λ Xs → return (meta-vars-solve-tp Γ Xs x tp synthesizing)
  >>=s λ Xs → match-types-ok $ meta-vars-update-kinds Γ Xs Xs)

match-types Γ Xs Ls unf (TpApp tpₓ₁ (Ttp tpₓ₂)) (TpApp tp₁ (Ttp tp₂)) =
    match-types Γ Xs Ls unf tpₓ₁ tp₁
  >>=s λ Xs' → match-types Γ Xs' Ls (match-unfolding-next unf) tpₓ₂ tp₂

match-types Γ Xs Ls unf (TpApp tpₓ (Ttm tmₓ)) (TpApp tp (Ttm tm)) =
    match-types Γ Xs Ls unf tpₓ tp
  >>=s λ Xs' →
    return $ if ~ conv-term Γ tmₓ tm
      then (match-error m-err.e-match-failure) else
    match-ok Xs'

match-types Γ Xs Ls unf tpₓ'@(TpAbs bₓ xₓ tkₓ tpₓ) tp'@(TpAbs b x tk tp) =
  if bₓ xor b
    then (match-types-error m-err.e-match-failure)
    else (match-tpkds Γ Xs Ls (match-unfolding-next unf) tkₓ tk >>=s λ Xs' →
          match-types (Γ→Γ' Γ) Xs' Ls' (match-unfolding-next unf) tpₓ tp)
  where
  Γ→Γ' : ctxt → ctxt
  Γ→Γ' Γ = ctxt-rename xₓ x (ctxt-var-decl-if x Γ)
  Ls' = stringset-insert Ls x

match-types Γ Xs Ls unf (TpIota xₓ mₓ tpₓ) (TpIota x m tp) =
  match-types Γ Xs Ls (match-unfolding-next unf) mₓ m
  >>=s λ Xs →
    match-types (Γ→Γ' Γ) Xs Ls' (match-unfolding-next unf) tpₓ tp
  where
  Γ→Γ' : ctxt → ctxt
  Γ→Γ' Γ = ctxt-rename xₓ x (ctxt-var-decl-if x Γ)
  Ls' = stringset-insert Ls x

match-types Γ Xs Ls unf (TpEq t₁ₓ t₂ₓ) (TpEq t₁ t₂) =
  if ~ conv-term Γ t₁ₓ t₁
    then match-types-error $ m-err.e-match-failure else
  if ~ conv-term Γ t₂ₓ t₂
    then match-types-error $ m-err.e-match-failure else
  match-types-ok Xs

match-types Γ Xs Ls unf (TpLam xₓ atkₓ tpₓ) (TpLam x atk tp) =
  match-tpkds Γ Xs Ls (match-unfolding-next unf) atkₓ atk >>=s λ Xs →
  match-types (Γ→Γ' Γ) Xs Ls' (match-unfolding-next unf) tpₓ tp
  where
  Γ→Γ' : ctxt → ctxt
  Γ→Γ' Γ = ctxt-rename xₓ x (ctxt-var-decl-if x Γ)
  Ls' = stringset-insert Ls x

match-types Γ Xs Ls unf tpₓ tp =
  match-types-error m-err.e-match-failure

-- match-kinds
-- --------------------------------------------------

-- match-kinds-norm: match already normalized kinds
match-kinds-norm : ctxt → meta-vars → local-vars → match-unfolding-state → (kₓ k : kind) → spanM $ match-error-t meta-vars

-- kind pi
match-kinds-norm Γ Xs Ls uf (KdAbs xₓ tkₓ kₓ) (KdAbs x tk k) =
  match-tpkds Γ Xs Ls uf tkₓ tk >>=s λ Xs →
  match-kinds (Γ→Γ' Γ) Xs Ls' uf kₓ k
  where
  Γ→Γ' = ctxt-rename xₓ x ∘ ctxt-var-decl-if x
  Ls' = stringset-insert Ls x

match-kinds-norm Γ Xs Ls uf KdStar KdStar =
  match-types-ok $ Xs
match-kinds-norm Γ Xs Ls uf kₓ k =
  match-types-error $ m-err.e-matchk-failure -- m-err.e-kind-ineq Γ kₓ k

match-kinds Γ Xs Ls uf kₓ k =
  match-kinds-norm Γ Xs Ls uf
    (hnf Γ unfold-head-elab kₓ)
    (hnf Γ unfold-head-elab k)

-- match-tk
-- --------------------------------------------------
match-tpkds Γ Xs Ls uf (Tkk kₓ) (Tkk k) = match-kinds Γ Xs Ls uf kₓ k
match-tpkds Γ Xs Ls uf (Tkt tpₓ) (Tkt tp) = match-types Γ Xs Ls uf tpₓ tp
match-tpkds Γ Xs Ls uf tkₓ tk =
  match-types-error m-err.e-matchk-failure -- m-err.e-tk-ineq Γ tkₓ tk

-- match-prototype
-- --------------------------------------------------

match-prototype-err : type → prototype → spanM match-prototype-data
match-prototype-err tp pt = return $ mk-match-prototype-data meta-vars-empty (decor-error tp pt) tt

{-
  --------------------
  Xs ⊢? T ≔ ⁇ ⇒ (∅ , T)
-}
match-prototype Γ Xs uf tp (proto-maybe nothing) =
  return $ mk-match-prototype-data Xs (decor-type tp) ff

{-
  Xs ⊢= T ≔ S ⇒ σ
  --------------------
  Xs ⊢? T ≔ S ⇒ (σ , T)
-}
match-prototype Γ Xs uf tp pt@(proto-maybe (just tp')) =
  match-types Γ Xs empty-trie match-unfolding-both tp tp'
    on-fail (λ _ → return $ mk-match-prototype-data Xs (decor-error tp pt) tt)
  >>=s λ Xs' → return $ mk-match-prototype-data Xs' (decor-type tp) ff

{-
  Xs,X ⊢? T ≔ ⁇ → P ⇒ (σ , W)
  -----------------------------------------------
  Xs ⊢? ∀ X . T ≔ ⁇ → P ⇒ (σ - X , ∀ X = σ(X) . W)
-}
match-prototype Γ Xs uf (TpAbs bₓ x (Tkk k) tp) pt'@(proto-arrow e? pt) =
  -- 1) generate a fresh meta-var Y, add it to the meta-vars, and rename
  --    occurences of x in tp to Y
  let ret = meta-vars-add-from-tpabs Γ missing-span-location Xs Erased x k tp
      Y = fst ret ; Xs' = snd ret ; tp' = subst Γ (meta-var-to-type-unsafe Y) x tp
  -- 2) match the body against the original prototype to generate a decorated type
  --    and find some solutions
  in match-prototype Γ Xs' ff tp' pt'
  >>= λ ret →
  let mk-match-prototype-data Xs' dt err = ret
      Y' = maybe-else' (meta-vars-lookup Xs' (meta-var-name Y)) Y λ Y → Y
      x' = subst-rename-var-if{TYPE} Γ empty-renamectxt x empty-trie tp'
  -- 3) replace the meta-vars with the bound type variable
  in subst-decortype (ctxt-var-decl x' Γ) (TpVar x') (meta-var-name Y) dt
  -- 4) leave behind the solution for Y as a decoration and drop Y from Xs
  >>= λ dt' →
  let sort' = meta-var.sort (meta-var-set-src Y' checking)
      dt″ = decor-decor Erased x (Tkk k) sort' dt' in
  return $ mk-match-prototype-data (meta-vars-remove Xs' Y) dt″ err

{-
  Xs ⊢? T ≔ P ⇒ (σ , P)
  -----------------------------
  Xs ⊢? S → T ≔ ⁇ → P ⇒ (σ , P)
-}
match-prototype Γ Xs uf (TpAbs b x (Tkt dom) cod) (proto-arrow e? pt) =
  match-prototype Γ Xs ff cod pt
  >>= λ ret →
  let mk-match-prototype-data Xs dt err = ret
      dt' = decor-decor b x (Tkt dom) (meta-var-tm dom nothing) dt
  in return $ if b xor e?
    then mk-match-prototype-data meta-vars-empty dt' tt
  else mk-match-prototype-data Xs dt' err

{-
  X ∈ Xs
  -----------------------------------
  Xs ⊢? X ≔ ⁇ → P ⇒ (σ , (X , ⁇ → P))
-}
match-prototype Γ Xs tt tp@(TpVar x) pt@(proto-arrow _ _) =
  return $ mk-match-prototype-data Xs (decor-stuck tp pt) ff

-- everything else...
-- Types for which we should keep digging
match-prototype Γ Xs ff tp@(TpVar x) pt@(proto-arrow _ _) =
  match-prototype Γ Xs tt (hnf Γ unfold-head-elab tp) pt
match-prototype Γ Xs ff tp@(TpApp _ _) pt@(proto-arrow _ _) =
  match-prototype Γ Xs tt (hnf Γ unfold-head-elab tp) pt
-- types for which we should suspend disbelief
match-prototype Γ Xs tt tp@(TpApp _ _) pt@(proto-arrow _ _) =
  return $ mk-match-prototype-data Xs (decor-stuck tp pt) ff
-- types which clearly do not match the prototype
match-prototype Γ Xs uf tp@(TpEq _ _) pt@(proto-arrow _ _) =
  match-prototype-err tp pt
match-prototype Γ Xs uf tp@(TpHole _) pt@(proto-arrow _ _) =
  match-prototype-err tp pt
match-prototype Γ Xs uf tp@(TpLam _ _ _) pt@(proto-arrow _ _) =
  match-prototype-err tp pt
match-prototype Γ Xs uf tp@(TpIota _ _ _) pt@(proto-arrow _ _) =
  match-prototype-err tp pt


--{-# OPTIONS --allow-unsolved-metas #-}

module StateSizedIO.GUI.WxGraphicsLibLevel3 where

open import StateSizedIO.GUI.Prelude

data GuiLev1Command  : Set where
  putStrLn     : String  →  GuiLev1Command
  createFrame  : GuiLev1Command
  addButton    : Frame → Button → GuiLev1Command

  createTextCtrl     : Frame   → String → GuiLev1Command
  fireCustomEvent    : Frame   → GuiLev1Command
  setAttribButton    : Button  → WxColor → GuiLev1Command
  setAttribTextCtrl  : TextCtrl  → WxColor → GuiLev1Command
  setChildredLayout  : Frame   → ℕ → ℕ → ℕ → ℕ → GuiLev1Command
  createButton       : Frame   → String → GuiLev1Command
  deleteButton       : Button  → GuiLev1Command
  deleteTextCtrl     : TextCtrl → GuiLev1Command
  drawBitmap         : DC      → Bitmap → Point → Bool → GuiLev1Command
  repaint            : Frame   → GuiLev1Command
  bitmapGetWidth     : Bitmap  → GuiLev1Command

GuiLev1Response : GuiLev1Command → Set
GuiLev1Response  createFrame         = Frame
GuiLev1Response  (createButton _ _)    = Button
GuiLev1Response  (bitmapGetWidth _)  = ℤ
GuiLev1Response  (createTextCtrl _ _)    = TextCtrl
GuiLev1Response _                    =  Unit

GuiLev1Interface  :  IOInterface
GuiLev1Interface  .Command   =  GuiLev1Command
GuiLev1Interface  .Response  =  GuiLev1Response

GuiLev2State : Set₁
GuiLev2State = VarList

data GuiLev2Command (s :  GuiLev2State) : Set₁ where
  level1C        : GuiLev1Command → GuiLev2Command s
  createVar      : {A : Set} → A → GuiLev2Command s
  setButtonHandler :
    Button
    → List (prod s → IO GuiLev1Interface ∞ (prod s))
    → GuiLev2Command s
  setTimer          : Frame → ℤ → List (prod s → IO GuiLev1Interface ∞ (prod s))
                      → GuiLev2Command s
  setKeyHandler     : Button
                      → List (prod s → IO GuiLev1Interface ∞ (prod s))
                      → List (prod s → IO GuiLev1Interface ∞ (prod s))
                      → List (prod s → IO GuiLev1Interface ∞ (prod s))
                      → List (prod s → IO GuiLev1Interface ∞ (prod s))
                      → GuiLev2Command s
  setOnPaint        : Frame
                     → List (prod s → DC → Rect → IO GuiLev1Interface ∞ (prod s))
                     → GuiLev2Command s

GuiLev2Response : (s : GuiLev2State)
                  → GuiLev2Command s → Set
GuiLev2Response _ (level1C c) = GuiLev1Response c
GuiLev2Response _ (createVar {A} a) = Var A
GuiLev2Response _ (setTimer fra x p) = Timer
GuiLev2Response _ _ = Unit

GuiLev2Next : (s : GuiLev2State) (c : GuiLev2Command s)
              → GuiLev2Response s c
              → GuiLev2State
GuiLev2Next s (createVar {A} a) var = addVar A var s
GuiLev2Next s _  _                  = s

GuiLev2Interface : IOInterfaceˢ
Stateˢ     GuiLev2Interface = GuiLev2State
Commandˢ   GuiLev2Interface = GuiLev2Command
Responseˢ  GuiLev2Interface = GuiLev2Response
nextˢ      GuiLev2Interface = GuiLev2Next

translateLev1Local :  (c : GuiLev1Command)
                      → NativeIO (GuiLev1Response c)
translateLev1Local createFrame            = nativeCreateFrame

translateLev1Local (setChildredLayout win a b c d) = nativeSetChildredLayout win a b c d
translateLev1Local (createButton fra str)   = nativeMakeButton fra str
translateLev1Local (deleteButton bt)      = nativeDeleteButton bt
translateLev1Local (deleteTextCtrl txt)   = nativeDeleteTextCtrl txt
translateLev1Local (addButton fra bt)     = nativeAddButton fra bt
translateLev1Local (setAttribButton bt col) = nativeSetColorButton bt col

translateLev1Local (setAttribTextCtrl txt col) = nativeSetColorTextCtrl txt col
translateLev1Local (drawBitmap dc bm p b) = nativeDrawBitmap dc bm p b
translateLev1Local (repaint fra)          = nativeRepaint fra
translateLev1Local (bitmapGetWidth b)     = nativeBitmapGetWidth b
translateLev1Local (putStrLn s)           = nativePutStrLn s
translateLev1Local (fireCustomEvent fr)   = nativeFireCustomEvent fr
translateLev1Local (createTextCtrl f str) = nativeMakeTextCtrl f str

translateLev1 : {A : Set} → IO GuiLev1Interface ∞ A → NativeIO A
translateLev1 = translateIO translateLev1Local

translateLev1List : {A : Set} → List (IO GuiLev1Interface ∞ A) → List (NativeIO A)
translateLev1List l = map translateLev1 l

translateLev2Local : (s : GuiLev2State)
                          → (c : GuiLev2Command s)
                          → NativeIO (GuiLev2Response s c)
translateLev2Local s (level1C c) = translateLev1Local c

translateLev2Local s (createVar {A} a)   = nativeNewVar {A} a
translateLev2Local s (setButtonHandler bt proglist)
    = nativeSetButtonHandler bt
            (dispatchList s (map (λ prog → translateLev1 ∘ prog)  proglist))

translateLev2Local s (setTimer fra interv proglist)
    = nativeSetTimer fra interv (dispatchList s (map (λ prog → translateLev1 ∘ prog)  proglist))

translateLev2Local s (setKeyHandler bt proglistRight proglistLeft proglistUp proglistDown)
    =  nativeSetKeyHandler bt
           (λ key -> case (showKey key) of λ
                 { "Right" → (dispatchList s (map (λ prog → translateLev1 ∘ prog)  proglistRight))
                 ; "Left" → (dispatchList s (map (λ prog → translateLev1 ∘ prog)  proglistLeft))
                 ; "Up" → (dispatchList s (map (λ prog → translateLev1 ∘ prog)  proglistUp))
                 ; "Down" → (dispatchList s (map (λ prog → translateLev1 ∘ prog)  proglistDown))
                 ; _  → nativeReturn unit
                 } )

translateLev2Local s (setOnPaint fra proglist)
    = nativeSetOnPaint fra (λ dc rect → (dispatchList s
         (map (λ prog aa → translateLev1 (prog aa dc rect)) proglist)))

translateLev2 : {s : GuiLev2State} → {A : Set}
                     → IOˢ GuiLev2Interface ∞ (λ _ → A) s → NativeIO A
translateLev2 = translateIOˢ {I = GuiLev2Interface} translateLev2Local

data GuiLev3Command (s :  GuiLev2State) : Set₂ where
  level2C : GuiLev2Command s → GuiLev3Command s
  setCustomEvent :
    Frame
    →  List
       ((x : prod s) → IOˢ GuiLev2Interface ∞ (λ _ → prod s) s)
    →  GuiLev3Command s

  setRightClick     : Frame → List ( (x : prod s) → IOˢ GuiLev2Interface ∞ (λ _ → prod s) s)
                     → GuiLev3Command s

GuiLev3Response : (s : GuiLev2State) → GuiLev3Command s → Set
GuiLev3Response s (level2C c)         = GuiLev2Response s c
GuiLev3Response _ _                   = Unit

GuiLev3Next : (s : GuiLev2State) → (c : GuiLev3Command s)
              → GuiLev3Response s c
              → GuiLev2State
GuiLev3Next s (level2C c) r = GuiLev2Next s c r
GuiLev3Next s (setRightClick _ _) _ = s
GuiLev3Next s (setCustomEvent _ _) _ = s

GuiLev3Interface : IOInterfaceˢ
GuiLev3Interface .Stateˢ = GuiLev2State
GuiLev3Interface .Commandˢ = GuiLev3Command
GuiLev3Interface .Responseˢ = GuiLev3Response
GuiLev3Interface .nextˢ = GuiLev3Next

translateLev3Local : (s : GuiLev2State)
                          → (c : GuiLev3Command s)
                          → NativeIO (GuiLev3Response s c)
translateLev3Local s (level2C c) = translateLev2Local s c
translateLev3Local s (setRightClick f proglist) =
    nativeSetClickRight f
           (dispatchList s (map (λ prog → translateLev2{s} ∘ prog ) proglist))

translateLev3Local s (setCustomEvent f proglist) =

    nativeRegisterCustomEvent f
           (dispatchList s (map (λ prog → translateLev2{s} ∘ prog ) proglist))

translateLev3 : {s : GuiLev2State} → {A : Set}
                     → IOˢ GuiLev3Interface ∞ (λ _ → A) s → NativeIO A
translateLev3 = translateIOˢ {I = GuiLev3Interface} translateLev3Local

mutual
  translateLev1toLev2∞ : ∀{s : GuiLev2State} → {A : Set}
                       → IO' GuiLev1Interface ∞ A → IOˢ' GuiLev2Interface ∞ (λ _ → A) s
  translateLev1toLev2∞ (do' c f) = doˢ' (level1C c) λ r → translateLev1toLev2 (f r)
  translateLev1toLev2∞ (return' a) = returnˢ' a

  translateLev1toLev2ₚ∞ : ∀{s : GuiLev2State} → {A : Set} → IO' GuiLev1Interface ∞ A
                                      → IOₚˢ' GuiLev2Interface ∞ A s s
  translateLev1toLev2ₚ∞ (do' c f) = doˢ' (level1C c) (λ r → translateLev1toLev2ₚ (f r))
  translateLev1toLev2ₚ∞ (return' a) = returnˢ' (refl , a)

  translateLev1toLev2 : ∀{s : GuiLev2State} → {A : Set}
                       → IO GuiLev1Interface ∞ A → IOˢ GuiLev2Interface ∞ (λ _ → A) s
  translateLev1toLev2 x .forceˢ = translateLev1toLev2∞ (x .force)

  translateLev1toLev2ₚ : ∀{s : GuiLev2State} → {A : Set}
                       → IO GuiLev1Interface ∞ A → IOₚˢ GuiLev2Interface ∞ A s s
  translateLev1toLev2ₚ x .forceˢ = translateLev1toLev2ₚ∞ (x .force)

mutual
  translateLev2toLev3∞ : ∀{α}{s : GuiLev2State} → {A : GuiLev2State → Set α}
                     → IOˢ' GuiLev2Interface ∞ A s → IOˢ' GuiLev3Interface ∞ A s
  translateLev2toLev3∞ (doˢ'{s} c f) = doˢ' (level2C c) λ r → translateLev2toLev3 (f r)
  translateLev2toLev3∞ (returnˢ' a) = returnˢ' a

  translateLev2toLev3 : ∀{α}{s : GuiLev2State} → {A : GuiLev2State → Set α}
                       → IOˢ GuiLev2Interface ∞ A s → IOˢ GuiLev3Interface ∞ A s
  translateLev2toLev3 x .forceˢ = translateLev2toLev3∞ (x .forceˢ)

--
-- Example
--
example : IO GuiLev1Interface ∞ Frame
example =
  do  createFrame                 λ frame  →
  do  (putStrLn "Frame created")  λ _      →
  return frame
private
 main : NativeIO Frame
 main = translateIO translateLev1Local example


{-#  OPTIONS --type-in-type #-}
module TooFewArgsWrongType where

open import AgdaPrelude

myFun : Vec Nat Zero -> Nat -> Nat
myFun x y = y

myApp : Nat
myApp = (myFun Zero)


-- {-# OPTIONS -v reify:100 -v syntax.reify:100  #-}
module Issue857b where

data ⊥ : Set where

⊥-elim : {A : Set} → ⊥ → A
⊥-elim ()

data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

_∋_ : (A : Set) → A → A
_ ∋ x = x

foo : {A B : Set} {x : ⊥} {y : B} →
      ((⊥ → A) ∋ λ()) x ≡ ((⊥ → B → A) ∋ λ()) x y
foo = refl

-- WAS: An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/Conversion.hs:514

bar : {A B C : Set} {x : ⊥} {y : B} {z : C} →
      ((⊥ → B → A) ∋ λ()) x y ≡ ((⊥ → C → A) ∋ λ()) x z
bar = refl

-- WAS:
-- .y != .z of type .B
-- when checking that the expression refl has type
-- ((⊥ → .B → .A) ∋ .Test.absurdLambda) .x .y ≡
-- ((⊥ → .C → .A) ∋ .Test.absurdLambda) .x .z

-- Note that z has type C, not B.

baz : {A : Set} → _≡_ {A = ⊥ → A} ⊥-elim (λ())
baz = refl

-- WAS: An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/Conversion.hs:51

-- ERROR: ⊥-elim x != (λ ()) x of type .A
-- when checking that the expression refl has type ⊥-elim ≡ (λ ())


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Lemmas
open import LibraBFT.Base.PKCS
open import LibraBFT.Base.Encode
open import LibraBFT.Base.KVMap as KVMap
open import LibraBFT.Impl.Base.Types
open import LibraBFT.Impl.Consensus.Types.EpochIndep
open import LibraBFT.Impl.Util.Crypto
open import LibraBFT.Abstract.Types.EpochConfig UID NodeId

-- This module defines the types that depend on an EpochConfig,
-- but never inspect it. Consequently, we define everyting over
-- an abstract 𝓔 passed around as a module parameter.
--
-- Importantly, though, we are connecting abstract and concrete
-- votes by defining what constitutes enough "evidence" that a
-- vote was cast, which is passed around in the abstract model as
-- the variable (𝓥 : VoteEvidence); here we instantiate it to
-- 'ConcreteVoteEvidence'.
--
-- TODO-3: update types to reflect more recent version of LibraBFT.
-- This is a substantial undertaking that should probably be led by
-- someone who can access our internal implementation.
--
-- TODO-4: Make the Optics.Reflection stuff work with record
-- parameters, so we can merge all modules back into Types.  For
-- now, this is the easiest way to avoid the issue that making a
-- module inside Consensus.Types called EpochDep will break
-- mkLens (not sure why).

module LibraBFT.Impl.Consensus.Types.EpochDep (𝓔 : EpochConfig) where
  open EpochConfig 𝓔
  open WithAbsVote 𝓔

  -- A 'ConcreteVoteEvidence' is a piece of information that
  -- captures that the 'vd : AbsVoteData' in question was not /invented/
  -- but instead, comes from a concrete vote that is /valid/ (that is,
  -- signature has been checked and author belongs to this epoch).
  --
  -- Moreover, we will also store the RecordChain that leads to the vote;
  -- this requires some mutually-recursive shenanigans, so we first declare
  -- ConcreteVoteEvidence, then import the necessary modules, and then define it.
  record ConcreteVoteEvidence (vd : AbsVoteData) : Set

  open import LibraBFT.Abstract.Abstract UID _≟UID_ NodeId 𝓔 ConcreteVoteEvidence as Abs hiding (qcVotes; Vote)

  data VoteCoherence (v : Vote) (b : Abs.Block) : Set where
    initial  : v ^∙ vParentId    ≡ genesisUID
             → v ^∙ vParentRound ≡ 0
             → Abs.bPrevQC b     ≡ nothing
             → VoteCoherence v b

    ¬initial : ∀{b' q}
             → v ^∙ vParentId    ≢ genesisUID
             → v ^∙ vParentRound ≢ 0
             → v ^∙ vParentId    ≡ Abs.bId b'
             → v ^∙ vParentRound ≡ Abs.bRound b'
             → (Abs.B b') ← (Abs.Q q)
             → (Abs.Q q)  ← (Abs.B b)
             → VoteCoherence v b

  -- Estabilishing validity of a concrete vote involves checking:
  --
  --   i) Vote author belongs to the current epoch
  --  ii) Vote signature is correctly verified
  -- iii) Existence of a RecordChain up to the voted-for block.
  --  iv) Coherence of 'vdParent' field with the above record chain.
  --
  record IsValidVote (v : Vote) : Set where
    constructor IsValidVote∙new
    inductive
    field
      ₋ivvMember   : Member
      ₋ivvAuthor   : isMember? (₋vAuthor v) ≡ just ₋ivvMember
      ₋ivvSigned   : WithVerSig (getPubKey ₋ivvMember) v

      ₋ivvVDhash   : v ^∙ vLedgerInfo ∙ liConsensusDataHash ≡ hashVD (v ^∙ vVoteData)

      -- A valid vote must vote for a block that exists and is
      -- inserted in a RecordChain.
      ₋ivvBlock    : Abs.Block
      ₋ivvBlockId  : v ^∙ vProposedId ≡ Abs.bId ₋ivvBlock

      -- Moreover; we must check that the 'parent' field of the vote is coherent.
      ₋ivvCoherent : VoteCoherence v ₋ivvBlock

      -- Finally, the vote is for the correct epoch
      ₋ivvEpoch    : v ^∙ vEpoch ≡ epoch
      ₋ivvEpoch2   : v ^∙ vParent ∙ biEpoch ≡ epoch  -- Not needed?
  open IsValidVote public

  -- A valid vote can be directly mapped to an AbsVoteData. Abstraction of QCs
  -- and blocks will be given in LibraBFT.Concrete.Records, since those are
  -- more involved functions.
  α-ValidVote : (v : Vote) → Member → AbsVoteData
  α-ValidVote v mbr = AbsVoteData∙new (v ^∙ vProposed ∙ biRound)
                                      mbr
                                      (v ^∙ vProposed ∙ biId)

  -- α-ValidVote is the same for two votes that have the same vAuthor, vdProposed and vOrder
  α-ValidVote-≡ : ∀ {cv v'} {m : Member}
                → ₋vdProposed (₋vVoteData cv) ≡ ₋vdProposed (₋vVoteData v')
                → α-ValidVote cv m ≡ α-ValidVote v' m
  α-ValidVote-≡ {cv} {v'} prop≡ =
    AbsVoteData-η (cong ₋biRound prop≡) refl (cong ₋biId prop≡)

  -- Finally; evidence for some abstract vote consists of a concrete valid vote
  -- that is coherent with the abstract vote data.
  record ConcreteVoteEvidence vd where
    constructor CVE∙new
    inductive
    field
      ₋cveVote        : Vote
      ₋cveIsValidVote : IsValidVote ₋cveVote
      ₋cveIsAbs       : α-ValidVote ₋cveVote (₋ivvMember ₋cveIsValidVote) ≡ vd
  open ConcreteVoteEvidence public

  -- Gets the signature of a concrete vote evidence
  ₋cveSignature : ∀{vd} → ConcreteVoteEvidence vd → Signature
  ₋cveSignature = ₋vSignature ∘ ₋cveVote

  -- A valid quorum certificate contains a collection of valid votes, such that
  -- the members represented by those votes (which exist because the votes are valid)
  -- constitutes a quorum.
  record MetaIsValidQC (qc : QuorumCert) : Set where
    field
      ₋ivqcMetaVotesValid      : All (IsValidVote ∘ rebuildVote qc) (qcVotes qc)
      ₋ivqcMetaIsQuorum        : IsQuorum (All-reduce ₋ivvMember ₋ivqcMetaVotesValid)
  open MetaIsValidQC public

  vqcMember : (qc : QuorumCert) → MetaIsValidQC qc
             → ∀ {as} → as ∈ qcVotes qc → Member
  vqcMember qc v {α , _ , _} as∈qc with All-lookup (₋ivqcMetaVotesValid v) as∈qc
  ...| prf = ₋ivvMember prf

  -- A block tree depends on a epoch config but works regardlesss of which
  -- EpochConfig we have.
  record BlockTree : Set where
    constructor BlockTree∙new
    field
      ₋btIdToBlock               : KVMap HashValue LinkableBlock
      ₋btRootId                  : HashValue
      ₋btHighestCertifiedBlockId : HashValue
      ₋btHighestQuorumCert       : QuorumCert
      -- btHighestTimeoutCert      : Maybe TimeoutCertificate
      ₋btHighestCommitCert       : QuorumCert
      ₋btPendingVotes            : PendingVotes
      ₋btPrunedBlockIds          : List HashValue
      ₋btMaxPrunedBlocksInMem    : ℕ
      ₋btIdToQuorumCert          : KVMap HashValue (Σ QuorumCert MetaIsValidQC)
  open BlockTree public
  unquoteDecl btIdToBlock   btRootId   btHighestCertifiedBlockId   btHighestQuorumCert
              btHighestCommitCert   btPendingVotes   btPrunedBlockIds
              btMaxPrunedBlocksInMem btIdToQuorumCert = mkLens (quote BlockTree)
             (btIdToBlock ∷ btRootId ∷ btHighestCertifiedBlockId ∷ btHighestQuorumCert ∷
              btHighestCommitCert ∷ btPendingVotes ∷ btPrunedBlockIds ∷
              btMaxPrunedBlocksInMem ∷ btIdToQuorumCert ∷ [])

  record BlockStore : Set where
    constructor BlockStore∙new
    field
      ₋bsInner         : BlockTree
      -- bsStateComputer : StateComputer
      -- bsStorage       : CBPersistentStorage
  open BlockStore public
  unquoteDecl bsInner = mkLens (quote BlockStore)
             (bsInner ∷ [])

  -- These are the parts of the RoundManager that depend on an
  -- EpochConfig. We do not particularly care which EpochConfig
  -- they care about yet.
  --
  record RoundManagerWithEC : Set where
    constructor RoundManagerWithEC∙new
    field
      ₋epBlockStore   : BlockStore
  open RoundManagerWithEC public
  unquoteDecl epBlockStore = mkLens (quote RoundManagerWithEC)
    (epBlockStore ∷ [])

  lBlockTree : Lens RoundManagerWithEC BlockTree
  lBlockTree = epBlockStore ∙ bsInner