{- 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.Hash
open import LibraBFT.Lemmas
open import LibraBFT.Base.KVMap
open import LibraBFT.Base.PKCS
open import LibraBFT.Base.Types
open import LibraBFT.Impl.Base.Types
open import LibraBFT.Impl.Consensus.Types
open import LibraBFT.Impl.Util.Crypto
open import LibraBFT.Impl.Handle sha256 sha256-cr
open import LibraBFT.Concrete.System.Parameters
open        EpochConfig
open import LibraBFT.Yasm.Yasm (ℓ+1 0ℓ) EpochConfig epochId authorsN ConcSysParms NodeId-PK-OK

-- This module defines an abstract system state given a reachable
-- concrete system state.

-- An implementation must prove that, if one of its handlers sends a
-- message that contains a vote and is signed by a public key pk, then
-- either the vote's author is the peer executing the handler, the
-- epochId is in range, the peer is a member of the epoch, and its key
-- in that epoch is pk; or, a message with the same signature has been
-- sent before.  This is represented by StepPeerState-AllValidParts.
module LibraBFT.Concrete.System (sps-corr : StepPeerState-AllValidParts) where

 -- Bring in 'unwind', 'ext-unforgeability' and friends
 open Structural sps-corr

 -- TODO-1: refactor this somewhere else?  Maybe something like
 -- LibraBFT.Impl.Consensus.Types.Properties?
 sameHonestSig⇒sameVoteData : ∀ {v1 v2 : Vote} {pk}
                            → Meta-Honest-PK pk
                            → WithVerSig pk v1
                            → WithVerSig pk v2
                            → v1 ^∙ vSignature ≡ v2 ^∙ vSignature
                            → NonInjective-≡ sha256 ⊎ v2 ^∙ vVoteData ≡ v1 ^∙ vVoteData
 sameHonestSig⇒sameVoteData {v1} {v2} hpk wvs1 wvs2 refl
    with verify-bs-inj (verified wvs1) (verified wvs2)
      -- The signable fields of the votes must be the same (we do not model signature collisions)
 ...| bs≡
      -- Therefore the LedgerInfo is the same for the new vote as for the previous vote
      = sym <⊎$> (hashVote-inj1 {v1} {v2} (sameBS⇒sameHash bs≡))

 honestVoteProps : ∀ {e st} → ReachableSystemState {e} st → ∀ {pk nm v sender}
                    → Meta-Honest-PK pk
                    → v ⊂Msg nm
                    → (sender , nm) ∈ msgPool st
                    → WithVerSig pk v
                    → NonInjective-≡ sha256 ⊎ v ^∙ vEpoch < e
 honestVoteProps r hpk v⊂m m∈pool ver
   with honestPartValid r hpk v⊂m m∈pool ver
 ...| msg , valid
   =  ⊎-map id (λ { refl → vp-epoch valid })
               (sameHonestSig⇒sameVoteData hpk ver (msgSigned msg)
                                           (sym (msgSameSig msg)))

 -- We are now ready to define an 'IntermediateSystemState' view for a concrete
 -- reachable state.  We will do so by fixing an epoch that exists in
 -- the system, which will enable us to define the abstract
 -- properties. The culminaton of this 'PerEpoch' module is seen in
 -- the 'IntSystemState' "function" at the bottom, which probably the
 -- best place to start uynderstanding this.  Longer term, we will
 -- also need higher-level, cross-epoch properties.
 module PerState {e}(st : SystemState e)(r : ReachableSystemState st) where

  -- TODO-3: Remove this postulate when we are satisfied with the
  -- "hash-collision-tracking" solution. For example, when proving voo
  -- (in LibraBFT.LibraBFT.Concrete.Properties.VotesOnce), we
  -- currently use this postulate to eliminate the possibility of two
  -- votes that have the same signature but different VoteData
  -- whenever we use sameHonestSig⇒sameVoteData.  To eliminate the
  -- postulate, we need to refine the properties we prove to enable
  -- the possibility of a hash collision, in which case the required
  -- property might not hold.  However, it is not sufficient to simply
  -- prove that a hash collision *exists* (which is obvious,
  -- regardless of the LibraBFT implementation).  Rather, we
  -- ultimately need to produce a specific hash collision and relate
  -- it to the data in the system, so that we can prove that the
  -- desired properties hold *unless* an actual hash collision is
  -- found by the implementation given the data in the system.  In
  -- the meantime, we simply require that the collision identifies a
  -- reachable state; later "collision tracking" will require proof
  -- that the colliding values actually exist in that state.
  postulate  -- temporary
    meta-sha256-cr : ¬ (NonInjective-≡ sha256)

  module PerEpoch (eid : Fin e) where
   𝓔 : EpochConfig
   𝓔 = EC-lookup (availEpochs st) eid
   open import LibraBFT.Abstract.Abstract     UID _≟UID_ NodeId 𝓔 (ConcreteVoteEvidence 𝓔) as Abs hiding (qcVotes; Vote)
   open import LibraBFT.Concrete.Intermediate                   𝓔 (ConcreteVoteEvidence 𝓔)
   open import LibraBFT.Concrete.Records                        𝓔

   -- * Auxiliary definitions;
   -- Here we capture the idea that there exists a vote message that
   -- witnesses the existence of a given Abs.Vote
   record ∃VoteMsgFor (v : Abs.Vote) : Set where
     constructor mk∃VoteMsgFor
     field
       -- A message that was actually sent
       nm            : NetworkMsg
       cv            : Vote
       cv∈nm         : cv ⊂Msg nm
       -- And contained a valid vote that, once abstracted, yeilds v.
       vmsgMember    : EpochConfig.Member 𝓔
       vmsgSigned    : WithVerSig (getPubKey 𝓔 vmsgMember) cv
       vmsg≈v        : α-ValidVote 𝓔 cv vmsgMember ≡ v
       vmsgEpoch     : cv ^∙ vEpoch ≡ epochId 𝓔
   open ∃VoteMsgFor public

   record ∃VoteMsgSentFor (sm : SentMessages)(v : Abs.Vote) : Set where
     constructor mk∃VoteMsgSentFor
     field
       vmFor        : ∃VoteMsgFor v
       vmSender     : NodeId
       nmSentByAuth : (vmSender , (nm vmFor)) ∈ sm
   open ∃VoteMsgSentFor public

   ∃VoteMsgSentFor-stable : ∀ {e e'} {pre : SystemState e} {post : SystemState e'} {v}
                          → Step pre post
                          → ∃VoteMsgSentFor (msgPool pre) v
                          → ∃VoteMsgSentFor (msgPool post) v
   ∃VoteMsgSentFor-stable theStep (mk∃VoteMsgSentFor sndr vmFor sba) =
                                   mk∃VoteMsgSentFor sndr vmFor (msgs-stable theStep sba)

   record ∃VoteMsgInFor (outs : List NetworkMsg)(v : Abs.Vote) : Set where
     constructor mk∃VoteMsgInFor
     field
       vmFor    : ∃VoteMsgFor v
       nmInOuts : nm vmFor ∈ outs
   open ∃VoteMsgInFor public

   ∈QC⇒sent : ∀{e} {st : SystemState e} {q α}
            → Abs.Q q α-Sent (msgPool st)
            → Meta-Honest-Member α
            → (vα : α Abs.∈QC q)
            → ∃VoteMsgSentFor (msgPool st) (Abs.∈QC-Vote q vα)
   ∈QC⇒sent {e} {st} {α = α} vsent@(ws {sender} {nm} e≡ nm∈st (qc∈NM {cqc} {q} .{nm} valid cqc∈nm q≡)) ha va
     with All-reduce⁻ {vdq = Any-lookup va} (α-Vote cqc valid) All-self
                      (subst (Any-lookup va ∈_) (cong Abs.qVotes q≡) (Any-lookup-correctP va))
   ...| as , as∈cqc , α≡
     with  α-Vote-evidence cqc valid  as∈cqc | inspect
          (α-Vote-evidence cqc valid) as∈cqc
   ...| ev | [ refl ]
      with vote∈qc {vs = as} as∈cqc refl cqc∈nm
   ...| v∈nm =
        mk∃VoteMsgSentFor
                 (mk∃VoteMsgFor nm (₋cveVote ev) v∈nm
                                (₋ivvMember (₋cveIsValidVote ev))
                                (₋ivvSigned (₋cveIsValidVote ev)) (sym α≡)
                                (₋ivvEpoch (₋cveIsValidVote ev)))
                 sender
                 nm∈st

   -- Finally, we can define the abstract system state corresponding to the concrete state st
   IntSystemState : IntermediateSystemState ℓ0
   IntSystemState = record
     { InSys           = λ { r → r α-Sent (msgPool st) }
     ; HasBeenSent     = λ { v → ∃VoteMsgSentFor (msgPool st) v }
     ; ∈QC⇒HasBeenSent = ∈QC⇒sent {st = st}
     }


module StateSizedIO.GUI.WxGraphicsLib where

open import SizedIO.Base
open import StateSizedIO.GUI.BaseStateDependent

open import Size renaming (Size to AgdaSize)

open import Data.Bool.Base
open import Data.List.Base
open import Data.Nat

open import Function
open import Data.Integer

open import NativeIO

open import StateSizedIO.GUI.WxBindingsFFI
open import StateSizedIO.GUI.VariableList

data GuiLev1Command  : Set where
  makeFrame          : GuiLev1Command
  setChildredLayout  : Frame   → ℕ → ℕ → ℕ → ℕ → GuiLev1Command
  makeButton         : Frame   → GuiLev1Command
  setAttribButton    : Button  → WxColor → GuiLev1Command
  addButton          : Frame   → Button → GuiLev1Command
  deleteButton       : Button → GuiLev1Command
  drawBitmap         : DC      → Bitmap → Point → Bool → GuiLev1Command
  repaint            : Frame   → GuiLev1Command
  bitmapGetWidth     : Bitmap  → GuiLev1Command
  putStrLn           : String  → GuiLev1Command

GuiLev1Response : GuiLev1Command → Set
GuiLev1Response makeFrame           = Frame
GuiLev1Response (makeButton _)      = Button
GuiLev1Response (bitmapGetWidth _)  = ℤ
GuiLev1Response _                   = Unit

GuiLev1Interface : IOInterface
Command   GuiLev1Interface = GuiLev1Command
Response  GuiLev1Interface = 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 makeFrame              = nativeNewFrame "dummy title"
translateLev1Local (setChildredLayout win a b c d) = nativeSetChildredLayout win a b c d
translateLev1Local (makeButton fra)       = nativeMakeButton fra "dummy button label"
translateLev1Local (deleteButton bt)      = nativeDeleteButton bt
translateLev1Local (addButton fra bt)     = nativeAddButton fra bt
translateLev1Local (setAttribButton bt col) = nativeSetColorButton bt 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

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


-- An ATP axiom must be used with postulates or data constructors.

-- This error is detected by TypeChecking.Rules.Decl.

module ATPBadAxiom where

foo : Set → Set
foo A = A
{-# ATP axiom foo #-}


module MissingDefinition where

T : Set -> Set


module Issue452 where

data Bool : Set where
  true false : Bool

data ⊥ : Set where

record ⊤ : Set where
  constructor tt

abstract

  id : Bool → Bool
  id b = b

If_then_else_ : Bool → Set → Set → Set
If true  then t else f = t
If false then t else f = f

data D : (b : Bool) → If b then ⊤ else ⊥ → Set where
  d : D (id true) _  -- this meta variable (type If (id true) ...) is unsolvable

foo : D true tt → ⊥
foo ()
-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/Rules/LHS/Unify.hs:402

{- Trying to unify

  D true tt = D (id true) _

true = id true is postponed, but then tt is handled of type

  If (id true)...

which is not a data or record type, causing the panic

Solution: do not postpone but fail, since in D : (b : Bool) -> X

  X depends on b

-}


module Sessions.Semantics.Process where

open import Level
open import Size
open import Data.Nat
open import Data.Sum
open import Data.Product
open import Data.Unit
open import Data.Bool
open import Debug.Trace

open import Function
open import Relation.Unary hiding (Empty)
open import Relation.Unary.PredicateTransformer using (PT)
open import Relation.Binary.PropositionalEquality hiding ([_])

open import Sessions.Syntax.Types
open import Sessions.Syntax.Values
open import Sessions.Syntax.Expr

open import Sessions.Semantics.Commands

open import Relation.Ternary.Separation
open import Relation.Ternary.Separation.Allstar
open import Relation.Ternary.Separation.Construct.Market
open import Relation.Ternary.Separation.Construct.Product
open import Relation.Ternary.Separation.Morphisms
open import Relation.Ternary.Separation.Monad
open import Relation.Ternary.Separation.Bigstar
open import Relation.Ternary.Separation.Monad.Free Cmd δ as Free hiding (step)
open import Relation.Ternary.Separation.Monad.State
open import Relation.Ternary.Separation.Monad.Error

open Monads using (Monad; str; typed-str)
open Monad {{...}}

data Exc : Set where
  outOfFuel : Exc
  delay     : Exc

open import Sessions.Semantics.Runtime delay
open import Sessions.Semantics.Communication delay

data Thread : Pred RCtx 0ℓ where
  forked :         ∀[ Comp unit ⇒ Thread ]
  main   : ∀ {a} → ∀[ Comp a ⇒ Thread ]

Pool : Pred RCtx 0ℓ
Pool = Bigstar Thread

St = Π₂ Pool ✴ Channels

open ExceptMonad {A = RCtx} Exc
open StateWithErr {C = RCtx} Exc

onPool : ∀ {P} → ∀[ (Pool ─✴ Except Exc (P ✴ Pool)) ⇒ State? St P ]
app (onPool f) (lift (snd pool ×⟨ σ , σ₁ ⟩ chs) k) (offerᵣ σ₂) with resplit σ₂ σ₁ k
... | _ , _ , τ₁ , τ₂ , τ₃ =
  case app f pool τ₁ of λ where
    (error e) → partial (inj₁ e)
    (✓ (p ×⟨ σ₃ ⟩ p')) →
      let _ , _ , τ₄ , τ₅ , τ₆ = resplit σ₃ τ₂ τ₃
      in return (inj p ×⟨ offerᵣ τ₄ ⟩ lift (snd p' ×⟨ σ , τ₅ ⟩ chs) τ₆)

onChannels : ∀ {P} → ∀[ State? Channels P ⇒ State? St P ]
app (onChannels f) μ (offerᵣ σ₃) with ○≺●ᵣ μ
... | inj pool ×⟨ offerᵣ σ₄ ⟩ chs with ⊎-assoc σ₃ (⊎-comm σ₄)
... | _ , τ₁ , τ₂ = do
  px ×⟨ σ₄ ⟩ ●chs ×⟨ σ₅ ⟩ inj pool ←
    mapM (app f chs (offerᵣ τ₁) &⟨ J Pool ∥ offerₗ τ₂ ⟩ inj pool) ✴-assocᵣ
  return (px ×⟨ σ₄ ⟩ app (○≺●ₗ pool) ●chs (⊎-comm σ₅))

enqueue : ∀[ Thread ⇒ State? St Emp ]
enqueue thr =
  onPool (wand λ pool σ → return (empty ×⟨ ⊎-idˡ ⟩ (app (append thr) pool σ)))

-- Smart reschedule of a thread:
-- Escalates out-of-fuel erros in threads, and discards terminated workers.
reschedule : ∀[ Thread ⇒ State? St Emp ]

reschedule (forked (partial (pure (inj₁ _))))  = raise outOfFuel
reschedule (forked (partial (pure (inj₂ tt)))) = return empty
reschedule thr@(forked (partial (impure _)))   = enqueue thr

reschedule (main (partial (pure (inj₁ _))))     = raise outOfFuel
reschedule thr@(main (partial (pure (inj₂ _)))) = enqueue thr
reschedule thr@(main (partial (impure _)))      = enqueue thr

{- Select the next thread that is not done -}
dequeue : ε[ State? St (Emp ∪ Thread) ]
dequeue =
  onPool (wandit (λ pool →
    case (find isImpure pool) of λ where
      (error e)              → return (inj₁ empty ×⟨ ⊎-idˡ ⟩ pool)
      (✓ (thr ×⟨ σ ⟩ pool')) → return (inj₂ thr ×⟨ σ ⟩ pool')))
  where
    isImpure : ∀ {Φ} → Thread Φ → Bool
    isImpure (main   (partial (pure _)))   = false
    isImpure (main   (partial (impure _))) = true
    isImpure (forked (partial (pure _)))   = false
    isImpure (forked (partial (impure _))) = true

module _ where

  handle : ∀ {Φ} → (c : Cmd Φ) → State? St (δ c) Φ
  handle (fork thr)           = trace "handle:fork"   $ enqueue (forked thr)
  handle (mkchan α)           = trace "handle:mkchan" $ onChannels newChan
  handle (send (ch ×⟨ σ ⟩ v)) = trace "handle:send"   $ onChannels (app (send! ch) v σ)
  handle (receive ch)         = trace "handle:recv"   $ onChannels (receive? ch)
  handle (close ch)           = trace "handle:close"  $ onChannels (closeChan ch)

  step : ∀[ Thread ⇒ State? St Thread ]
  step thr@(main (partial c))   = do
    c' ← Free.step handle c
    return (main (partial c'))
  step (forked (partial c)) = do
    c' ← Free.step handle c
    return (forked (partial c'))

  -- try the first computation; if it fails with a 'delay' exception,
  -- then queue t
  _orDelay_ : ∀[ State? St Emp ⇒ Thread ⇒ State? St Emp ]
  c orDelay t = do
    c orElse λ where
      delay     → enqueue t
      outOfFuel → raise outOfFuel

  -- Run a pool of threads in round-robing fashion
  -- until all have terminated, or fuel runs out
  run : ℕ → ε[ State? St Emp ]
  run zero    = raise outOfFuel
  run (suc n) = do
    inj₂ thr ← dequeue
      -- if we cannot dequeue a thunked thread, we're done
      where (inj₁ e) → return e

    -- otherwise we take a step
    empty ← trace "run:step" (do thr' ← step thr; enqueue thr') orDelay thr

    -- rinse and repeat
    run n

  start : ℕ → Thread ε → ∃ λ Φ → Except Exc (● St) Φ
  start n thr = -, do
    let μ = lift (snd [ thr ] ×⟨ ⊎-idʳ ⟩ nil) ⊎-idʳ
    inj empty ×⟨ σ ⟩ μ ← app (run n) μ (offerᵣ ⊎-idˡ)
    case ⊎-id⁻ˡ σ of λ where
      refl → return μ

    where open ExceptMonad {A = Market RCtx} Exc


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Caching evaluation
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term

import Parametric.Syntax.MType as MType
import Parametric.Syntax.MTerm as MTerm

import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Denotation.MValue as MValue
import Parametric.Denotation.CachingMValue as CachingMValue
import Parametric.Denotation.MEvaluation as MEvaluation

module Parametric.Denotation.CachingMEvaluation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    (ValConst : MTerm.ValConstStructure Const)
    (CompConst : MTerm.CompConstStructure Const)
    (cbnToCompConst : MTerm.CbnToCompConstStructure Const CompConst)
    (cbvToCompConst : MTerm.CbvToCompConstStructure Const CompConst)
    -- I should really switch to records - can it get sillier than this? More
    -- precisely, this is the kind of thing ML functors are designed to replace.
    -- They have also subtyping --- not sure whether that's good or bad.
    (⟦_⟧ValBase : MEvaluation.ValStructure Const ⟦_⟧Base ValConst CompConst cbnToCompConst cbvToCompConst)
    (⟦_⟧CompBase : MEvaluation.CompStructure Const ⟦_⟧Base ValConst CompConst cbnToCompConst cbvToCompConst)
    (ΔBase : CachingMValue.Structure Base ⟦_⟧Base)
  where

open Type.Structure Base
open Term.Structure Base Const

open MType.Structure Base
open MTerm.Structure Const ValConst CompConst cbnToCompConst cbvToCompConst

open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open MValue.Structure Base ⟦_⟧Base
open CachingMValue.Structure Base ⟦_⟧Base ΔBase
open MEvaluation.Structure Const ⟦_⟧Base ValConst CompConst cbnToCompConst cbvToCompConst ⟦_⟧ValBase ⟦_⟧CompBase

open import Base.Denotation.Notation

-- Extension Point: Evaluation of constants.
ValStructure : Set
ValStructure = ∀ {τ} → ValConst τ → ⟦ τ ⟧ValTypeHidCache

CompStructure : Set
CompStructure = ∀ {τ} → CompConst τ → ⟦ τ ⟧CompTypeHidCache

module Structure
       (⟦_⟧ValBaseTermCache  : ValStructure)
       (⟦_⟧CompBaseTermCache : CompStructure)
    where

  {-
  -- Prototype here the type-correctness of a simple non-standard semantics.
  -- This describes a simplified version of the transformation by Liu and
  -- Tanenbaum, PEPM 1995 - but for now, instead of producing object language
  -- terms, we produce host language terms to take advantage of the richer type
  -- system of the host language (in particular, here we need the unit type,
  -- product types and *existentials*).
  --
  -- As usual, we'll later switch to a real term transformation.
  -}
  open import Data.Product hiding (map)
  open import Data.Unit

  -- Defining a caching semantics for Term proves to be hard, requiring to
  -- insert and remove caches where we apply constants.

  -- Indeed, our plugin interface is not satisfactory for adding caching. CBPV can help us.

  -- The solution is to distinguish among different kinds of constants. Some are
  -- value constructors (and thus do not return caches), while others are
  -- computation constructors (and thus should return caches). For products, I
  -- believe we will only use positive/value products (i.e. pattern-match products),
  -- not negative/computation products (i.e. projection products).
  ⟦_⟧CompTermCache : ∀ {τ Γ} → Comp Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦_⟧ValTermCache : ∀ {τ Γ} → Val Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache
  ⟦_⟧ValsTermCache : ∀ {Γ Σ} → Vals Γ Σ → ⟦ Γ ⟧ValCtxHidCache → ⟦ Σ ⟧ValCtxHidCache

  open import Base.Denotation.Environment ValType ⟦_⟧ValTypeHidCache public
    using ()
    renaming (⟦_⟧Var to ⟦_⟧ValVarHidCache)

  -- This says that the environment does not contain caches... sounds wrong!
  -- Either we add extra variables for the caches, or we store computations in
  -- the environment (but that does not make sense), or we store caches in
  -- values, by acting not on F but on something else (U?).

  -- Copy of ⟦_⟧Vals
  ⟦ ∅ ⟧ValsTermCache ρ = ∅
  ⟦ vt • valtms ⟧ValsTermCache ρ = ⟦ vt ⟧ValTermCache ρ • ⟦ valtms ⟧ValsTermCache ρ

  -- I suspect the plan was to use extra variables; that's annoying to model in
  -- Agda but easier in implementations.

  ⟦ vVar   x ⟧ValTermCache ρ = ⟦ x ⟧ValVarHidCache ρ
  ⟦ vThunk x ⟧ValTermCache ρ = ⟦ x ⟧CompTermCache ρ
  -- No caching, because the arguments are values, so evaluating them does not
  -- produce intermediate results.
  ⟦ vConst c ⟧ValTermCache ρ = ⟦ c ⟧ValBaseTermCache

  -- The only caching is done by the interpretation of the constant (because the
  -- arguments are values so need no caching).
  ⟦_⟧CompTermCache (cConst c) ρ = ⟦ c ⟧CompBaseTermCache

  -- Also, where are introduction forms for pairs and sums among values? With
  -- them, we should see that we can interpret them without adding a cache.

  -- Thunks keep seeming noops.
  ⟦_⟧CompTermCache (cForce x) ρ = ⟦ x ⟧ValTermCache ρ

  -- The effect of F is a writer monad of cached values, where the monoid is
  -- (isomorphic to) the free monoid over (∃ τ . τ), but we push the
  -- existentials up when pairing things!

  -- That's what we're interpreting computations in. In fact, one could use
  -- monads directly, but that does not deal with arity satisfactorily.
  ⟦_⟧CompTermCache (cReturn v) ρ = vUnit , (⟦ v ⟧ValTermCache ρ , tt)

  -- A function can invoke, in tail position, either a `cReturn` directly, or
  -- invoke another function. In the latter case, we need to ensure that the
  -- return value of the other function is not forwarded directly, but that
  -- further intermediate results from the current function are also recorded.
  --
  -- At one time, `f1 into cReturn` did this correctly, but `f1` didn't, while
  -- instead, they should be equivalent. In other words, we want `_into_` to
  -- satisfy the monadic laws for bind.

  {-
  -- Here we'd have a problem with the original `_into_` constructor from CBPV, because it does
  -- not require converting expressions to the "CBPV A-normal form".
  --
  -- If we tried supporting it, we could try to write something like:

  ⟦_⟧CompTermCache (v₁ into v₂) ρ =
  -- Sequence commands and combine their caches.
  {-
    let (_ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (_ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))
  -}

  -- However, the code above does not work, because we only guarantee that v₂ is
  -- a computation, not that it's an F-computation - v₂ could also be function
  -- type or a computation product.

  -- Instead, we use a restricted CBPV, where these two possibilities are forbidden.
  -- If you want to save something between different lambdas, you need to add an
  -- F U to reflect that. (Double-check the papers which show how to encode
  -- arity using CBPV, it seems that they should find the same problem ---
  -- XXX they don't).
  -}

  -- But if we alter _into_ as described above, composing the caches works!
  -- However, we should not forget we also need to save the new intermediate
  -- result, that is the one produced by the first part of the let.
  ⟦_⟧CompTermCache (_into_ {σ} {τ} v₁ v₂) ρ =
    let (τ₁ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (τ₂ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in  (τ₁ v× τ₂ v× σ) , (r₂ ,′ (c₁ ,′ c₂  ,′ r₁))

  -- Note the compositionality and luck: we don't need to do anything at the
  -- cReturn time, we just need the nested into to do their job, because as I
  -- said intermediate results are a writer monad.
  --
  -- Q: But then, do we still need to do all the other stuff? IOW, do we still
  -- need to forbid (λ x . y <- f args; g args') and replace it with (λ x . y <-
  -- f args; z <- g args'; z)?
  --
  -- A: One thing we still need is using the monadic version of into for the
  -- same reasons - which makes sense, since it has the type of monadic bind.
  --
  -- Maybe not: if we use a monad, which respects left and right identity, the
  -- two above forms are equivalent. But what about associativity? We don't have
  -- associativity with nested tuples in the middle. That's why the monad uses
  -- lists! We can also use nested tuple, as long as in the into case we don't
  -- do (a, b) but append a b (ahem, where?), which decomposes the first list
  -- and prepends it to the second. To this end, we need to know the type of the
  -- first element, or to ensure it's always a pair. XXX: We should just reuse
  -- HList.

  -- In abstractions, we should start collecting all variables...

  -- Here, unlike in ⟦_⟧TermCache, we don't need to invent an empty cache,
  -- that's moved into the handling of cReturn. This makes *the* difference for
  -- nested lambdas, where we don't need to create caches multiple times!

  ⟦_⟧CompTermCache (cAbs v) ρ = λ x → ⟦ v ⟧CompTermCache (x • ρ)

  -- Here we see that we are in a sort of A-normal form, because the argument is
  -- a value (not quite ANF though, since values can be thunks - that is,
  -- computations which haven't been run yet, I guess. Do we have an use for
  -- that? That allows passing lambdas as arguments directly - which is fine,
  -- because producing a closure indeed does not have intermediate results!).
  ⟦_⟧CompTermCache (cApp t v) ρ = ⟦ t ⟧CompTermCache ρ (⟦ v ⟧ValTermCache ρ)

  ⟦_⟧TermCacheCBV : ∀ {τ Γ} → Term Γ τ → ⟦ fromCBVCtx Γ ⟧ValCtxHidCache → ⟦ cbvToCompType τ ⟧CompTypeHidCache
  ⟦ t ⟧TermCacheCBV = ⟦ fromCBV t ⟧CompTermCache

  module _ (ι : Base) where
    Γ : ValContext
    Γ = ∅
    σ = B ι
    τ = B ι
    f : Comp Γ (σ ⇛ F τ)
    f = cAbs (cReturn (vVar vThis))

    bar : ⟦ σ ⇛ F τ ⟧CompTypeHidCache
    bar = ⟦ f ⟧CompTermCache ∅

    open import Relation.Binary.PropositionalEquality
    bar≡ : bar ≡ (λ x → vUnit , x , tt)
    bar≡ = refl

    dbar : ⟦ σ ⇛ F τ ⟧ΔCompType
    dbar = λ dx → vUnit , λ c₀ → (dx , c₀)

    barbaz : ⟦ base ι ⟧Type → ⟦ ΔBase ι ⟧Type → ⟦ base ι ⟧Type × ⟦ ΔBase ι ⟧Type
    barbaz x dx =
      let
          (τ₁ , y , c₁) = bar x
          (τ₂ , dbar′) = dbar dx
          (dy , c₂) = dbar′ c₁
      in y , dy
    module _ (f : ⟦ σ ⇛ F τ ⟧CompTypeHidCache) (df : ⟦ σ ⇛ F τ ⟧ΔCompType)
      (proof : ∀ x dx → proj₁ (f x) ≡ proj₁ (df dx)) where

      -- fdf₁ : ⟦ base ι ⟧Type → ⟦ ΔBase ι ⟧Type → ⟦ base ι ⟧Type × ⟦ ΔBase ι ⟧Type
      -- fdf₁ x dx =
      --   let
      --     (τ₁ , y , c₁) = f x
      --     (τ₂ , dbar′) = df dx
      --     --(dy , c₂) = dbar′ c₁ -- fails, as it should be expected!
      --   in y , dy

      fdf : ⟦ base ι ⟧Type → ⟦ ΔBase ι ⟧Type → ⟦ base ι ⟧Type × ⟦ ΔBase ι ⟧Type
      fdf x dx with proof x dx
      ... | p =
        let
          (τ₁ , y , c₁) = f x
          (τ₂ , dbar′) = df dx
          (dy , c₂) = dbar′ (subst ⟦_⟧ValTypeHidCache p c₁) --
        in y , dy


module Tactic.Reflection.Equality where

open import Prelude
open import Builtin.Reflection
open import Builtin.Float

instance
  EqVisibility : Eq Visibility
  _==_ {{EqVisibility}} visible  visible  = yes refl
  _==_ {{EqVisibility}} visible  hidden   = no (λ ())
  _==_ {{EqVisibility}} visible  instance′ = no (λ ())
  _==_ {{EqVisibility}} hidden   visible  = no (λ ())
  _==_ {{EqVisibility}} hidden   hidden   = yes refl
  _==_ {{EqVisibility}} hidden   instance′ = no (λ ())
  _==_ {{EqVisibility}} instance′ visible  = no (λ ())
  _==_ {{EqVisibility}} instance′ hidden   = no (λ ())
  _==_ {{EqVisibility}} instance′ instance′ = yes refl

  EqRelevance : Eq Relevance
  _==_ {{EqRelevance}} relevant   relevant   = yes refl
  _==_ {{EqRelevance}} relevant   irrelevant = no (λ ())
  _==_ {{EqRelevance}} irrelevant relevant   = no (λ ())
  _==_ {{EqRelevance}} irrelevant irrelevant = yes refl

  EqArgInfo : Eq ArgInfo
  _==_ {{EqArgInfo}} (arg-info v r) (arg-info v₁ r₁) =
    decEq₂ arg-info-inj₁ arg-info-inj₂ (v == v₁) (r == r₁)

  EqArg : ∀ {A} {{EqA : Eq A}} → Eq (Arg A)
  _==_ {{EqArg}} (arg i x) (arg i₁ x₁) = decEq₂ arg-inj₁ arg-inj₂ (i == i₁) (x == x₁)

  EqLiteral : Eq Literal
  _==_ {{EqLiteral}} = eqLit
    where
      eqLit : (x y : Literal) → Dec (x ≡ y)
      eqLit (nat    x) (nat    y) = decEq₁ nat-inj    (x == y)
      eqLit (word64 x) (word64 y) = decEq₁ word64-inj (x == y)
      eqLit (float  x) (float  y) = decEq₁ float-inj  (x == y)
      eqLit (char   x) (char   y) = decEq₁ char-inj   (x == y)
      eqLit (string x) (string y) = decEq₁ string-inj (x == y)
      eqLit (name   x) (name   y) = decEq₁ name-inj   (x == y)
      eqLit (meta   x) (meta   y) = decEq₁ meta-inj   (x == y)

      eqLit (nat    _) (float  _) = no λ()
      eqLit (nat    _) (word64 _) = no λ()
      eqLit (nat    _) (char   _) = no λ()
      eqLit (nat    _) (string _) = no λ()
      eqLit (nat    _) (name   _) = no λ()
      eqLit (nat    _) (meta   _) = no λ()
      eqLit (word64 _) (nat    _) = no λ()
      eqLit (word64 _) (float  _) = no λ()
      eqLit (word64 _) (char   _) = no λ()
      eqLit (word64 _) (string _) = no λ()
      eqLit (word64 _) (name   _) = no λ()
      eqLit (word64 _) (meta   _) = no λ()
      eqLit (float  _) (nat    _) = no λ()
      eqLit (float  _) (word64 _) = no λ()
      eqLit (float  _) (char   _) = no λ()
      eqLit (float  _) (string _) = no λ()
      eqLit (float  _) (name   _) = no λ()
      eqLit (float  _) (meta   _) = no λ()
      eqLit (char   _) (nat    _) = no λ()
      eqLit (char   _) (word64 _) = no λ()
      eqLit (char   _) (float  _) = no λ()
      eqLit (char   _) (string _) = no λ()
      eqLit (char   _) (name   _) = no λ()
      eqLit (char   _) (meta   _) = no λ()
      eqLit (string _) (nat    _) = no λ()
      eqLit (string _) (word64 _) = no λ()
      eqLit (string _) (float  _) = no λ()
      eqLit (string _) (char   _) = no λ()
      eqLit (string _) (name   _) = no λ()
      eqLit (string _) (meta   _) = no λ()
      eqLit (name   _) (nat    _) = no λ()
      eqLit (name   _) (word64 _) = no λ()
      eqLit (name   _) (float  _) = no λ()
      eqLit (name   _) (char   _) = no λ()
      eqLit (name   _) (string _) = no λ()
      eqLit (name   _) (meta   _) = no λ()
      eqLit (meta   _) (nat    _) = no λ()
      eqLit (meta   _) (word64 _) = no λ()
      eqLit (meta   _) (float  _) = no λ()
      eqLit (meta   _) (char   _) = no λ()
      eqLit (meta   _) (string _) = no λ()
      eqLit (meta   _) (name   _) = no λ()

private
  eqSort   : (x y : Sort)    → Dec (x ≡ y)
  eqTerm   : (x y : Term)    → Dec (x ≡ y)
  eqPat    : (x y : Pattern) → Dec (x ≡ y)
  eqClause : (x y : Clause)  → Dec (x ≡ y)

  eqArgTerm : (x y : Arg Term) → Dec (x ≡ y)
  eqArgTerm (arg i x) (arg i₁ x₁) = decEq₂ arg-inj₁ arg-inj₂ (i == i₁) (eqTerm x x₁)

  eqArgPat : (x y : Arg Pattern) → Dec (x ≡ y)
  eqArgPat (arg i x) (arg i₁ x₁) = decEq₂ arg-inj₁ arg-inj₂ (i == i₁) (eqPat x x₁)

  eqAbsTerm : (x y : Abs Term) → Dec (x ≡ y)
  eqAbsTerm (abs s x) (abs s₁ x₁) = decEq₂ abs-inj₁ abs-inj₂ (s == s₁) (eqTerm x x₁)

  eqPats : (x y : List (Arg Pattern)) → Dec (x ≡ y)
  eqPats [] [] = yes refl
  eqPats [] (x ∷ xs) = no λ ()
  eqPats (x ∷ xs) [] = no λ ()
  eqPats (x ∷ xs) (y ∷ ys) = decEq₂ cons-inj-head cons-inj-tail (eqArgPat x y) (eqPats xs ys)

  eqArgs : (x y : List (Arg Term)) → Dec (x ≡ y)
  eqArgs [] [] = yes refl
  eqArgs [] (x ∷ xs) = no λ ()
  eqArgs (x ∷ xs) [] = no λ ()
  eqArgs (x ∷ xs) (y ∷ ys) = decEq₂ cons-inj-head cons-inj-tail (eqArgTerm x y) (eqArgs xs ys)

  eqClauses : (x y : List Clause) → Dec (x ≡ y)
  eqClauses [] [] = yes refl
  eqClauses [] (x ∷ xs) = no λ ()
  eqClauses (x ∷ xs) [] = no λ ()
  eqClauses (x ∷ xs) (y ∷ ys) = decEq₂ cons-inj-head cons-inj-tail (eqClause x y) (eqClauses xs ys)

  eqTerm (var x args) (var x₁ args₁) = decEq₂ var-inj₁ var-inj₂ (x == x₁) (eqArgs args args₁)
  eqTerm (con c args) (con c₁ args₁) = decEq₂ con-inj₁ con-inj₂ (c == c₁) (eqArgs args args₁)
  eqTerm (def f args) (def f₁ args₁) = decEq₂ def-inj₁ def-inj₂ (f == f₁) (eqArgs args args₁)
  eqTerm (meta x args) (meta x₁ args₁) = decEq₂ meta-inj₁ meta-inj₂ (x == x₁) (eqArgs args args₁)
  eqTerm (lam v x) (lam v₁ y) = decEq₂ lam-inj₁ lam-inj₂ (v == v₁) (eqAbsTerm x y)
  eqTerm (pi t₁ t₂) (pi t₃ t₄) = decEq₂ pi-inj₁ pi-inj₂ (eqArgTerm t₁ t₃) (eqAbsTerm t₂ t₄)
  eqTerm (agda-sort x) (agda-sort x₁) = decEq₁ sort-inj (eqSort x x₁)
  eqTerm (lit l) (lit l₁)   = decEq₁ lit-inj (l == l₁)
  eqTerm (pat-lam c args) (pat-lam c₁ args₁) = decEq₂ pat-lam-inj₁ pat-lam-inj₂ (eqClauses c c₁) (eqArgs args args₁)
  eqTerm unknown unknown = yes refl

  eqTerm (var x args) (con c args₁) = no λ ()
  eqTerm (var x args) (def f args₁) = no λ ()
  eqTerm (var x args) (lam v y) = no λ ()
  eqTerm (var x args) (pi t₁ t₂) = no λ ()
  eqTerm (var x args) (agda-sort x₁) = no λ ()
  eqTerm (var x args) (lit x₁) = no λ ()
  eqTerm (var x args) unknown = no λ ()
  eqTerm (con c args) (var x args₁) = no λ ()
  eqTerm (con c args) (def f args₁) = no λ ()
  eqTerm (con c args) (lam v y) = no λ ()
  eqTerm (con c args) (pi t₁ t₂) = no λ ()
  eqTerm (con c args) (agda-sort x) = no λ ()
  eqTerm (con c args) (lit x) = no λ ()
  eqTerm (con c args) unknown = no λ ()
  eqTerm (def f args) (var x args₁) = no λ ()
  eqTerm (def f args) (con c args₁) = no λ ()
  eqTerm (def f args) (lam v y) = no λ ()
  eqTerm (def f args) (pi t₁ t₂) = no λ ()
  eqTerm (def f args) (agda-sort x) = no λ ()
  eqTerm (def f args) (lit x) = no λ ()
  eqTerm (def f args) unknown = no λ ()
  eqTerm (lam v x) (var x₁ args) = no λ ()
  eqTerm (lam v x) (con c args) = no λ ()
  eqTerm (lam v x) (def f args) = no λ ()
  eqTerm (lam v x) (pi t₁ t₂) = no λ ()
  eqTerm (lam v x) (agda-sort x₁) = no λ ()
  eqTerm (lam v x) (lit x₁) = no λ ()
  eqTerm (lam v x) unknown = no λ ()
  eqTerm (pi t₁ t₂) (var x args) = no λ ()
  eqTerm (pi t₁ t₂) (con c args) = no λ ()
  eqTerm (pi t₁ t₂) (def f args) = no λ ()
  eqTerm (pi t₁ t₂) (lam v y) = no λ ()
  eqTerm (pi t₁ t₂) (agda-sort x) = no λ ()
  eqTerm (pi t₁ t₂) (lit x) = no λ ()
  eqTerm (pi t₁ t₂) unknown = no λ ()
  eqTerm (agda-sort x) (var x₁ args) = no λ ()
  eqTerm (agda-sort x) (con c args) = no λ ()
  eqTerm (agda-sort x) (def f args) = no λ ()
  eqTerm (agda-sort x) (lam v y) = no λ ()
  eqTerm (agda-sort x) (pi t₁ t₂) = no λ ()
  eqTerm (agda-sort x) (lit x₁) = no λ ()
  eqTerm (agda-sort x) unknown = no λ ()
  eqTerm (lit x) (var x₁ args) = no λ ()
  eqTerm (lit x) (con c args) = no λ ()
  eqTerm (lit x) (def f args) = no λ ()
  eqTerm (lit x) (lam v y) = no λ ()
  eqTerm (lit x) (pi t₁ t₂) = no λ ()
  eqTerm (lit x) (agda-sort x₁) = no λ ()
  eqTerm (lit x) unknown = no λ ()
  eqTerm unknown (var x args) = no λ ()
  eqTerm unknown (con c args) = no λ ()
  eqTerm unknown (def f args) = no λ ()
  eqTerm unknown (lam v y) = no λ ()
  eqTerm unknown (pi t₁ t₂) = no λ ()
  eqTerm unknown (agda-sort x) = no λ ()
  eqTerm unknown (lit x) = no λ ()

  eqTerm (var _ _) (meta _ _) = no λ ()
  eqTerm (con _ _) (meta _ _) = no λ ()
  eqTerm (def _ _) (meta _ _) = no λ ()
  eqTerm (lam _ _) (meta _ _) = no λ ()
  eqTerm (pi _ _) (meta _ _) = no λ ()
  eqTerm (agda-sort _) (meta _ _) = no λ ()
  eqTerm (lit _) (meta _ _) = no λ ()
  eqTerm unknown (meta _ _) = no λ ()
  eqTerm (meta _ _) (var _ _) = no λ ()
  eqTerm (meta _ _) (con _ _) = no λ ()
  eqTerm (meta _ _) (def _ _) = no λ ()
  eqTerm (meta _ _) (lam _ _) = no λ ()
  eqTerm (meta _ _) (pi _ _) = no λ ()
  eqTerm (meta _ _) (agda-sort _) = no λ ()
  eqTerm (meta _ _) (lit _) = no λ ()
  eqTerm (meta _ _) unknown = no λ ()

  eqTerm (var _ _) (pat-lam _ _) = no λ ()
  eqTerm (con _ _) (pat-lam _ _) = no λ ()
  eqTerm (def _ _) (pat-lam _ _) = no λ ()
  eqTerm (lam _ _) (pat-lam _ _) = no λ ()
  eqTerm (pi _ _) (pat-lam _ _) = no λ ()
  eqTerm (meta _ _) (pat-lam _ _) = no λ ()
  eqTerm (agda-sort _) (pat-lam _ _) = no λ ()
  eqTerm (lit _) (pat-lam _ _) = no λ ()
  eqTerm unknown (pat-lam _ _) = no λ ()
  eqTerm (pat-lam _ _) (var _ _) = no λ ()
  eqTerm (pat-lam _ _) (con _ _) = no λ ()
  eqTerm (pat-lam _ _) (def _ _) = no λ ()
  eqTerm (pat-lam _ _) (lam _ _) = no λ ()
  eqTerm (pat-lam _ _) (pi _ _) = no λ ()
  eqTerm (pat-lam _ _) (meta _ _) = no λ ()
  eqTerm (pat-lam _ _) (agda-sort _) = no λ ()
  eqTerm (pat-lam _ _) (lit _) = no λ ()
  eqTerm (pat-lam _ _) unknown = no λ ()

  eqSort (set t) (set t₁) = decEq₁ set-inj (eqTerm t t₁)
  eqSort (lit n) (lit n₁) = decEq₁ slit-inj (n == n₁)
  eqSort unknown unknown = yes refl
  eqSort (set t) (lit n) = no λ ()
  eqSort (set t) unknown = no λ ()
  eqSort (lit n) (set t) = no λ ()
  eqSort (lit n) unknown = no λ ()
  eqSort unknown (set t) = no λ ()
  eqSort unknown (lit n) = no λ ()

  eqPat (con c ps) (con c₁ ps₁) = decEq₂ pcon-inj₁ pcon-inj₂ (c == c₁) (eqPats ps ps₁)
  eqPat  dot        dot         = yes refl
  eqPat (var s)    (var s₁)     = decEq₁ pvar-inj (s == s₁)
  eqPat (lit l)    (lit l₁)     = decEq₁ plit-inj (l == l₁)
  eqPat (proj f)   (proj f₁)    = decEq₁ proj-inj (f == f₁)
  eqPat  absurd     absurd      = yes refl

  eqPat (con _ _) dot      = no λ ()
  eqPat (con _ _) (var _)  = no λ ()
  eqPat (con _ _) (lit _)  = no λ ()
  eqPat (con _ _) (proj _) = no λ ()
  eqPat (con _ _) absurd   = no λ ()

  eqPat dot (con _ _) = no λ ()
  eqPat dot (var _)   = no λ ()
  eqPat dot (lit _)   = no λ ()
  eqPat dot (proj _)  = no λ ()
  eqPat dot absurd    = no λ ()

  eqPat (var _) (con _ _) = no λ ()
  eqPat (var _) dot       = no λ ()
  eqPat (var _) (lit _)   = no λ ()
  eqPat (var _) (proj _)  = no λ ()
  eqPat (var _) absurd    = no λ ()

  eqPat (lit _) (con _ _) = no λ ()
  eqPat (lit _) dot       = no λ ()
  eqPat (lit _) (var _)   = no λ ()
  eqPat (lit _) (proj _)  = no λ ()
  eqPat (lit _) absurd    = no λ ()

  eqPat (proj _) (con _ _) = no λ ()
  eqPat (proj _) dot       = no λ ()
  eqPat (proj _) (var _)   = no λ ()
  eqPat (proj _) (lit _)   = no λ ()
  eqPat (proj _) absurd    = no λ ()

  eqPat absurd (con _ _) = no λ ()
  eqPat absurd dot       = no λ ()
  eqPat absurd (var _)   = no λ ()
  eqPat absurd (lit _)   = no λ ()
  eqPat absurd (proj _)  = no λ ()

  eqClause (clause ps t)      (clause ps₁ t₁)     = decEq₂ clause-inj₁ clause-inj₂ (eqPats ps ps₁) (eqTerm t t₁)
  eqClause (absurd-clause ps) (absurd-clause ps₁) = decEq₁ absurd-clause-inj (eqPats ps ps₁)
  eqClause (clause _ _) (absurd-clause _) = no λ ()
  eqClause (absurd-clause _) (clause _ _) = no λ ()

instance
  EqTerm : Eq Term
  _==_ {{EqTerm}} = eqTerm

  EqSort : Eq Sort
  _==_ {{EqSort}} = eqSort

  EqClause : Eq Clause
  _==_ {{EqClause}} = eqClause

  EqPattern : Eq Pattern
  _==_ {{EqPattern}} = eqPat


-- {-# OPTIONS -v tc.term.con:100 #-}
module Issue799 where

data D : Set where
  d : D

x : D
x = d {_} {_} {interesting-argument = _} {_} {_} {_}
  -- should fail


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

   Copyright (c) 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 LibraBFT.Base.Types
open import LibraBFT.Impl.OBM.Logging.Logging
import      LibraBFT.Impl.Types.Ledger2WaypointConverter as Ledger2WaypointConverter
open import LibraBFT.ImplShared.Consensus.Types
import      LibraBFT.ImplShared.Util.Crypto              as Crypto
open import Optics.All
open import Util.Hash
open import Util.Prelude

module LibraBFT.Impl.Types.Waypoint where

newAny : LedgerInfo → Waypoint
newAny ledgerInfo =
  let converter = Ledger2WaypointConverter.new ledgerInfo
   in Waypoint∙new (ledgerInfo ^∙ liVersion) (Crypto.hashL2WC converter)

newEpochBoundary : LedgerInfo → Either ErrLog Waypoint
newEpochBoundary ledgerInfo =
  if ledgerInfo ^∙ liEndsEpoch
  then pure (newAny ledgerInfo)
  else Left fakeErr -- ["newEpochBoundary", "no validator set"]

verify : Waypoint → LedgerInfo → Either ErrLog Unit
verify self ledgerInfo = do
  lcheck (self ^∙ wVersion == ledgerInfo ^∙ liVersion)
         ("Waypoint" ∷ "version mismatch" ∷ []) --show (self^.wVersion), show (ledgerInfo^.liVersion)]
  let converter = Ledger2WaypointConverter.new ledgerInfo
  lcheck (self ^∙ wValue == Crypto.hashL2WC converter)
         ("Waypoint" ∷ "value mismatch" ∷ []) --show (self^.wValue), show (Crypto.hashL2WC converter)]
  pure unit

epochChangeVerificationRequired : Waypoint → Epoch → Bool
epochChangeVerificationRequired _self _epoch = true

isLedgerInfoStale : Waypoint → LedgerInfo → Bool
isLedgerInfoStale self ledgerInfo = ⌊ (ledgerInfo ^∙ liVersion) <?-Version (self ^∙ wVersion) ⌋

verifierVerify : Waypoint → LedgerInfoWithSignatures → Either ErrLog Unit
verifierVerify self liws = verify self (liws ^∙ liwsLedgerInfo)


{-# OPTIONS --without-K #-}

module Agda.Builtin.IO where

postulate IO : ∀ {a} → Set a → Set a
{-# BUILTIN IO IO #-}

{-# HASKELL type AgdaIO a b = IO b #-}
{-# COMPILED_TYPE IO MAlonzo.Code.Agda.Builtin.IO.AgdaIO #-}


module StateSizedIO.IOObject where

open import Data.Product

open import Size

open import SizedIO.Base
open import StateSizedIO.Object

-- ---
-- ---
-- ---  FILE IS DELETED !!!
-- ---
-- ---

-- An IO object is like a simple object,
-- but the method returns IO applied to the result type of a simple object
-- which means the method returns an IO program which when terminating
-- returns the result of the simple object

{- NOTE   IOObject is now replaced by IOObjectˢ as defined in
          StateSizedIO.Base
-}

{-
module _  (ioi  : IOInterface)  (let C = Command ioi)  (let R = Response ioi)
          (oi   : Interfaceˢ)    (let S = Stateˢ oi)     (let M  = Methodˢ oi)
                                (let Rt  = Resultˢ oi) (let next = nextˢ oi)

  where

  record IOObject (i : Size) (s : S) : Set where
    coinductive
    field
      method : ∀{j : Size< i} (m : M s) → IO ioi ∞ (Σ[ r ∈ Rt s m ] IOObject j (next s m r) )

open IOObject public
-}


import cedille-options
open import general-util

module untyped-spans (options : cedille-options.options) {F : Set → Set} ⦃ monadF : monad F ⦄ where

open import ctxt
open import cedille-types
open import constants
open import conversion
open import free-vars
open import rename
open import spans options {F} ⦃ monadF ⦄
open import subst
open import syntax-util
open import to-string options
open import type-util
open import elab-util options

{-# TERMINATING #-}
untyped-term : ctxt → ex-tm → spanM term
untyped-type : ctxt → ex-tp → spanM type
untyped-kind : ctxt → ex-kd → spanM kind
untyped-tpkd : ctxt → ex-tk → spanM tpkd
untyped-arg : ctxt → ex-arg → spanM arg
untyped-args : ctxt → ex-args → spanM args
untyped-let : ctxt → ex-def → erased? → posinfo → posinfo → spanM (ctxt × var × tagged-val × (∀ {ed : exprd} → ⟦ ed ⟧ → ⟦ ed ⟧) × (term → term))
untyped-cases : ctxt → ex-cases → renamectxt → spanM cases
untyped-case : ctxt → ex-case → (siblings : ℕ) → (ℕ → err-m) → renamectxt → spanM (case × (ℕ → err-m) × maybe ℕ)

untyped-let Γ (ExDefTerm pi x Tₑ? t) e? fm to =
  maybe-map (untyped-type Γ) Tₑ? >>=? λ Tₑ?~ →
  untyped-term Γ t >>= λ t~ →
  elim-pair (compileFail-in Γ t~) λ tvs e →
  let Tₑ~ = maybe-else' Tₑ?~ (TpHole pi) id in
  [- Var-span (Γ , pi - x :` Tkt Tₑ~) pi x untyped tvs e -]
  return
    (ctxt-term-def pi localScope opacity-open x (just t~) Tₑ~ Γ ,
     pi % x ,
     binder-data Γ pi x (Tkt Tₑ~) e? (just t~) fm to ,
     (λ {ed} T' → [ Γ - t~ / (pi % x) ] T') ,
     (λ t' → LetTm e? x nothing t~ ([ Γ - Var x / (pi % x) ] t')))

untyped-let Γ (ExDefType pi x k T) e? fm to =
  untyped-kind Γ k >>= λ k~ →
  untyped-type Γ T >>= λ T~ →
  [- TpVar-span (Γ , pi - x :` Tkk k~) pi x untyped [] nothing -]
  return
    (ctxt-type-def pi localScope opacity-open x (just T~) k~ Γ ,
     pi % x ,
     binder-data Γ pi x (Tkk k~) e? (just T~) fm to ,
     (λ {ed} T' → [ Γ - T~ / (pi % x) ] T') ,
     (λ t' → LetTp x k~ T~ ([ Γ - TpVar x / (pi % x) ] t')))

untyped-term Γ (ExApp t e t') =
  [- App-span tt (term-start-pos t) (term-end-pos t') untyped [] nothing -]
  untyped-term Γ t >>= λ t~ →
  untyped-term Γ t' >>= λ t'~ →
  return (if e then t~ else App t~ t'~)

untyped-term Γ (ExAppTp t T) =
  [- AppTp-span tt (term-start-pos t) (type-end-pos T) untyped [] nothing -]
  untyped-type Γ T >>= λ T~ →
  untyped-term Γ t

untyped-term Γ (ExBeta pi t? t?') =
  maybe-map (λ {(PosTm t pi) → untyped-term Γ t}) t? >>=? λ t?~ →
  maybe-map (λ {(PosTm t pi) → untyped-term Γ t}) t?' >>=? λ t?'~ →
  [- Beta-span pi (term-end-pos (ExBeta pi t? t?')) untyped [] nothing -]
  return (maybe-else' t?'~ id-term id)

untyped-term Γ (ExChi pi T? t) =
  maybe-map (untyped-type Γ) T? >>=? λ T?~ →
  [- Chi-span Γ pi T?~ t untyped [] nothing -]
  untyped-term Γ t

untyped-term Γ (ExDelta pi T? t) =
  [- Delta-span pi t untyped [] nothing -]
  maybe-map (untyped-type Γ) T? >>=? λ T?~ →
  untyped-term Γ t >>= λ t~ →
  return id-term

untyped-term Γ (ExEpsilon pi lr -? t) =
  [- Epsilon-span pi lr -? t untyped [] nothing -]
  untyped-term Γ t

untyped-term Γ (ExHole pi) =
  [- hole-span Γ pi nothing untyped [] -]
  return (Hole pi)

untyped-term Γ (ExIotaPair pi t₁ t₂ Tₘ? pi') =
  let tv-f = λ {(ExGuide pi'' x Tₘ) →
               [ binder-data Γ pi'' x (Tkt (TpHole pi'')) ff nothing
                   (type-start-pos Tₘ) (type-end-pos Tₘ) ]} in
  [- IotaPair-span pi pi' untyped (maybe-else' Tₘ? [] tv-f) nothing -]
  untyped-term Γ t₁ >>= λ t₁~ →
  untyped-term Γ t₂ >>= λ t₂~ →
  maybe-map (λ {(ExGuide pi'' x Tₘ) →
    untyped-type (ctxt-term-decl pi'' x (TpHole pi'') Γ) Tₘ}) Tₘ? >>=? λ Tₘ?~ →
  return t₁~

untyped-term Γ (ExIotaProj t n pi) =
  [- IotaProj-span t pi untyped [] nothing -]
  untyped-term Γ t

untyped-term Γ (ExLam pi e pi' x tk? t) =
  (return tk? on-fail return (Tkt (TpHole pi')) >>=m untyped-tpkd Γ) >>= λ tk~ →
  untyped-term (Γ , pi' - x :` tk~) t >>= λ t~ →
  let eₖ? = tk? >>= λ _ → ifMaybej (tk-is-type tk~ && ~ e)
                             "λ-terms must bind a term, not a type (use Λ instead)"
      eₑ? = ifMaybej (e && is-free-in (pi' % x) (erase t~))
               "The Λ-bound variable occurs free in the erasure of the body" in
  [- var-span e (Γ , pi' - x :` tk~) pi' x untyped tk~ eₑ? -]
  [- Lam-span Γ untyped pi pi' e x tk~ t [] eₖ? -]
  return (if e then t~ else Lam ff x nothing ([ Γ - Var x / (pi' % x) ] t~))

untyped-term Γ (ExLet pi e? d t) =
  untyped-let Γ d e? (term-start-pos t) (term-end-pos t) >>= λ where
    (Γ' , x , tv , σ , f) →
      untyped-term Γ' t >>= λ t~ →
      [- punctuation-span "Parens (let)" pi (term-end-pos t) -]
      [- Let-span e? pi (term-end-pos t) untyped []
           (ifMaybej (e? && is-free-in x t~)
             (unqual-local x ^ "occurs free in the body of the term")) -]
      return (if is-free-in x t~ then f t~ else t~)

untyped-term Γ (ExOpen pi o pi' x t) =
  [- Var-span Γ pi' x untyped [ not-for-navigation ] nothing -]
  [- Open-span o pi x t untyped [] nothing -]
  untyped-term Γ t

untyped-term Γ (ExParens pi t pi') =
  [- punctuation-span "Parens (term)" pi pi' -]
  untyped-term Γ t

untyped-term Γ (ExPhi pi t₌ t₁ t₂ pi') =
  [- Phi-span pi pi' untyped [] nothing -]
  untyped-term Γ t₌ >>
  untyped-term Γ t₁ >>
  untyped-term Γ t₂

untyped-term Γ (ExRho pi ρ+? ρ<ns>? t₌ Tₘ? t) =
  [- Rho-span pi t₌ t untyped ρ+?
       (maybe-else' Tₘ? (inj₁ 1) λ {(ExGuide pi' x Tₘ) → inj₂ x}) [] nothing -]
  untyped-term Γ t₌ >>
  maybe-map (λ {(ExGuide pi' x Tₘ) →
                  untyped-type (ctxt-var-decl-loc pi' x Γ) Tₘ}) Tₘ? >>=? λ Tₘ?~ →
  untyped-term Γ t

untyped-term Γ (ExVarSigma pi t) =
  [- VarSigma-span pi t untyped [] nothing -]
  untyped-term Γ t

untyped-term Γ (ExTheta pi θ t ts) =
  [- Theta-span Γ pi θ t ts untyped [] nothing -]
  untyped-term Γ t >>= λ t~ →
  untyped-args Γ (map (λ {(Lterm e t) → ExTmArg e t}) ts) >>= λ as~ →
  return (recompose-apps (map Arg (erase-args as~)) t~)

untyped-term Γ (ExMu pi pi''' x t Tₘ? pi' ms pi'') =
  untyped-term Γ t >>= λ t~ →
  maybe-map (untyped-type Γ) Tₘ? >>=? λ Tₘ~? →
   [- Var-span Γ pi''' x untyped [] nothing -]
      let Γ' = ctxt-term-decl pi''' x (TpHole pi''') Γ
          ρ = renamectxt-single (pi''' % x) x
          tvs = [ binder-data Γ' pi''' x (Tkt (TpHole pi''')) ff nothing pi' pi'' ] in
      untyped-cases Γ' ms ρ >>= λ ms~ →
      -- Make sure we aren't matching upon a "False" datatype (e.g., one
      -- with no constructors) before any datatypes have been declared
      maybe-else' (head2 (trie-mappings (ctxt.μ Γ)))
        ([- Mu-span Γ pi pi'' Tₘ~? untyped tvs
              (just "No datatypes have been declared yet") -]
         return (Hole pi))
        λ where
          (Dₓ , ps , kᵢ , k , cs , eds , ecs) →
            [- Mu-span Γ pi pi'' Tₘ~? untyped tvs nothing -]
            return (Mu x t~ nothing (mk-data-info Dₓ Dₓ (params-to-args ps) [] ps kᵢ k cs cs eds ecs) ms~)
untyped-term Γ (ExSigma pi t? t Tₘ? pi' ms pi'') =
  untyped-term Γ t >>= λ t~ →
  maybe-map (untyped-type Γ) Tₘ? >>=? λ Tₘ~? →
      maybe-map (untyped-term Γ) t? >>=? λ t~? →
      let ρ = empty-renamectxt
          μ~ = t~?
          tvs = [] in
      untyped-cases Γ ms ρ >>= λ ms~ →
      -- Make sure we aren't matching upon a "False" datatype (e.g., one
      -- with no constructors) before any datatypes have been declared
      maybe-else' (head2 (trie-mappings (ctxt.μ Γ)))
        ([- Mu-span Γ pi pi'' Tₘ~? untyped tvs
              (just "No datatypes have been declared yet") -]
         return (Hole pi))
        λ where
          (Dₓ , ps , kᵢ , k , cs , eds , ecs) →
            [- Mu-span Γ pi pi'' Tₘ~? untyped tvs nothing -]
            return (Sigma μ~ t~ nothing (mk-data-info Dₓ Dₓ (params-to-args ps) [] ps kᵢ k cs cs eds ecs) ms~)

-- x
untyped-term Γ (ExVar pi x) =
  maybe-else' (ctxt-binds-term-var Γ x)
    ([- Var-span Γ pi x untyped [] (just "Not a term variable") -]
    return (Var x))
    λ {(qx , as) →
      [- Var-span Γ pi x untyped [] nothing -]
      return (recompose-apps (map Arg (erase-args as)) (Var qx))}

-- ∀/Π x : tk. T
untyped-type Γ (ExTpAbs pi e pi' x tk T) =
  untyped-tpkd Γ tk >>= λ tk~ →
  untyped-type (Γ , pi' - x :` tk~) T >>= λ T~ →
  let T~ = rename-var Γ (pi' % x) x T~ in
  [- punctuation-span "Forall" pi (posinfo-plus pi 1) -]
  [- var-span e (Γ , pi' - x :` tk~) pi' x untyped tk~ nothing -]
  [- TpQuant-span Γ e pi pi' x tk~ T untyped [] nothing -]
  return (TpAbs e x tk~ T~)

-- ι x : T₁. T₂
untyped-type Γ (ExTpIota pi pi' x T₁ T₂) =
  untyped-type Γ T₁ >>= λ T₁~ →
  untyped-type (Γ , pi' - x :` Tkt T₁~) T₂ >>= λ T₂~ →
  let T₂~ = rename-var Γ (pi' % x) x T₂~ in
  [- punctuation-span "Forall" pi (posinfo-plus pi 1) -]
  [- var-span ff (Γ , pi' - x :` Tkt T₁~) pi' x untyped (Tkt T₁~) nothing -]
  [- Iota-span Γ pi pi' x T₂~ T₂ untyped [] nothing -]
  return (TpIota x T₁~ T₂~)

-- {^ T ^} (generated by theta)
untyped-type Γ (ExTpNoSpans T pi) = untyped-type Γ T >>=spand return

-- [d] - T
untyped-type Γ (ExTpLet pi d T) =
  untyped-let Γ d ff (type-start-pos T) (type-end-pos T) >>= λ where
    (Γ' , x , tv , σ , f) →
      untyped-type Γ' T >>= λ T~ →
      [- punctuation-span "Parens (let)" pi (type-end-pos T) -]
      [- TpLet-span pi (type-end-pos T) untyped [ tv ] -]
      return (σ T~)

-- T · T'
untyped-type Γ (ExTpApp T T') =
  untyped-type Γ T >>= λ T~ →
  untyped-type Γ T' >>= λ T'~ →
  [- TpApp-span (type-start-pos T) (type-end-pos T) untyped [] nothing -]
  return (TpAppTp T~ T'~)

-- T t
untyped-type Γ (ExTpAppt T t) =
  untyped-type Γ T >>= λ T~ →
  untyped-term Γ t >>= λ t~ →
  [- TpAppt-span (type-start-pos T) (term-end-pos t) untyped [] nothing -]
  return (TpAppTm T~ t~)

-- T ➔/➾ T'
untyped-type Γ (ExTpArrow T e T') =
  untyped-type Γ T >>= λ T~ →
  untyped-type Γ T' >>= λ T'~ →
  [- TpArrow-span T T' untyped [] nothing -]
  return (TpAbs e ignored-var (Tkt T~) T'~)

-- { t₁ ≃ t₂ }
untyped-type Γ (ExTpEq pi t₁ t₂ pi') =
  untyped-term Γ t₁ >>= λ t₁~ →
  untyped-term Γ t₂ >>= λ t₂~ →
  [- punctuation-span "Parens (equation)" pi pi' -]
  [- TpEq-span pi pi' untyped [] nothing -]
  return (TpEq t₁~ t₂~)

-- ●
untyped-type Γ (ExTpHole pi) =
  [- tp-hole-span Γ pi nothing untyped [] -]
  return (TpHole pi)

-- λ x : tk. T
untyped-type Γ (ExTpLam pi pi' x tk T) =
  untyped-tpkd Γ tk >>= λ tk~ →
  untyped-type (Γ , pi' - x :` tk~) T >>= λ T~ →
  [- punctuation-span "Lambda (type)" pi (posinfo-plus pi 1) -]
  [- var-span ff (Γ , pi' - x :` tk~) pi' x untyped tk~ nothing -]
  [- TpLambda-span Γ pi pi' x tk~ T untyped [] nothing -]
  return (TpLam x tk~ (rename-var Γ (pi' % x) x T~))

-- (T)
untyped-type Γ (ExTpParens pi T pi') =
  [- punctuation-span "Parens (type)" pi pi' -]
  untyped-type Γ T

-- x
untyped-type Γ (ExTpVar pi x) =
  maybe-else' (ctxt-binds-type-var Γ x)
    ([- TpVar-span Γ pi x untyped [] (just "Undefined type variable") -]
     return (TpVar x))
    λ {(qx , as) →
      [- TpVar-span Γ pi x untyped [] nothing -]
      return (apps-type (TpVar qx) (erase-args-keep as))}

-- Π x : tk. k
untyped-kind Γ (ExKdAbs pi pi' x tk k) =
  untyped-tpkd Γ tk >>= λ tk~ →
  untyped-kind (Γ , pi' - x :` tk~) k >>= λ k~ →
  [- KdAbs-span Γ pi pi' x tk~ k untyped nothing -]
  [- var-span ff (Γ , pi' - x :` tk~) pi' x untyped tk~ nothing -]
  [- punctuation-span "Pi (kind)" pi (posinfo-plus pi 1) -]
  return (KdAbs x tk~ (rename-var Γ (pi' % x) x k~))

-- tk ➔ k
untyped-kind Γ (ExKdArrow tk k) =
  untyped-tpkd Γ tk >>= λ tk~ →
  untyped-kind Γ k >>= λ k~ →
  [- KdArrow-span tk k untyped nothing -]
  return (KdAbs ignored-var tk~ k~)

-- ●
untyped-kind Γ (ExKdHole pi) =
  [- kd-hole-span pi untyped -]
  return (KdHole pi)

-- (k)
untyped-kind Γ (ExKdParens pi k pi') =
  [- punctuation-span "Parens (kind)" pi pi' -]
  untyped-kind Γ k

-- ★
untyped-kind Γ (ExKdStar pi) =
  [- Star-span pi untyped nothing -]
  return KdStar

-- κ as...
untyped-kind Γ (ExKdVar pi κ as) =
  case ctxt-lookup-kind-var-def Γ κ of λ where
    nothing →
      [- KdVar-span Γ (pi , κ) (args-end-pos (posinfo-plus-str pi κ) as) [] untyped []
           (just "Undefined kind variable") -]
      return (KdHole pi)
    (just (ps , k)) →
      untyped-args Γ as >>= λ as~ →
      [- KdVar-span Γ (pi , κ)
           (args-end-pos (posinfo-plus-str pi κ) as)
           ps untyped (params-data Γ ps)
           (unless (length as =ℕ length ps)
             ("Expected " ^ ℕ-to-string (length ps) ^
              " argument" ^ (if length ps =ℕ 1 then "" else "s") ^
              ", but got " ^ ℕ-to-string (length as))) -]
      return (fst (subst-params-args' Γ ps as~ k))

untyped-arg Γ (ExTmArg ff t) = inj₁ <$> untyped-term Γ t
untyped-arg Γ (ExTmArg tt t) = (inj₂ ∘ inj₁) <$> untyped-term Γ t
untyped-arg Γ (ExTpArg T) = (inj₂ ∘ inj₂) <$> untyped-type Γ T

untyped-args Γ = sequenceA ∘ map (untyped-arg Γ)

untyped-tpkd Γ (ExTkt T) = Tkt <$> untyped-type Γ T
untyped-tpkd Γ (ExTkk k) = Tkk <$> untyped-kind Γ k

untyped-cases Γ ms ρ =
  let msₗ = length ms in
  foldl (λ m rec ms f → untyped-case Γ m msₗ f ρ >>= uncurry₂ λ m asₗ n? → rec (maybe-else' n? ms (λ n → set-nth n (just m) ms)) asₗ)
    (const ∘ return) ms (repeat (length ms) nothing) (λ _ → nothing) >>=r drop-nothing

untyped-case-args : ctxt → posinfo → ex-case-args → ex-tm → renamectxt → spanM (case-args × term)
untyped-case-args Γ pi cas t ρ =
  foldr {B = ctxt → renamectxt → 𝕃 tagged-val → (term → spanM ⊤) → spanM (case-args × term)}
    (λ {(ExCaseArg me pi x) rec Γ' ρ tvs sm →
      let tk = case me of λ {ExCaseArgTp → Tkk (KdHole pi-gen);
                             ExCaseArgTm → Tkt (TpHole pi-gen);
                             ExCaseArgEr → Tkt (TpHole pi-gen)} in
      rec
        (ctxt-tk-decl pi x tk Γ')
        (renamectxt-insert ρ (pi % x) x)
        (binder-data Γ' pi x tk (ex-case-arg-erased me) nothing
          (term-start-pos t) (term-end-pos t) :: tvs)
        (λ t →
          [- var-span (ex-case-arg-erased me) Γ' pi x untyped tk
            (when (ex-case-arg-erased me && is-free-in (pi % x) (erase t))
              "The bound variable occurs free in the erasure of the body (not allowed)") -]
          sm t) >>=c λ cas →
      return2 (case me of λ {ExCaseArgTm → CaseArg ff x nothing :: cas; _ → cas})})
    (λ Γ' ρ tvs sm →
      [- pattern-clause-span pi t (reverse tvs) -]
      untyped-term Γ' t >>= λ t~ →
      sm t~ >>
      return2 [] (subst-renamectxt Γ' ρ t~))
    cas Γ ρ [] λ _ → spanMok

untyped-case Γ (ExCase pi x cas t) csₗ asₗ ρ =
  untyped-case-args Γ pi cas t ρ >>=c λ cas~ t~ →
  case (qual-lookup Γ x) of λ where
    (just (qx , as , ctr-def ps T Cₗ cᵢ cₐ , loc)) →
      let c~ = Case qx cas~ t~ []
          eᵢ = "This constructor overlaps with " ^ x
          eₐ = unless (length cas~ =ℕ cₐ)
                 ("Expected " ^ ℕ-to-string cₐ ^
                  " arguments after erasure, but got " ^ ℕ-to-string (length cas~))
          eₗ = unless (Cₗ =ℕ csₗ)
                 ("Constructor's datatype has " ^ ℕ-to-string Cₗ ^
                  (if Cₗ =ℕ 1 then " constructor" else " constructors") ^
                  ", but expected " ^ ℕ-to-string csₗ) in
      [- Var-span Γ pi x untyped [] (asₗ cᵢ ||-maybe (eₐ ||-maybe eₗ)) -]
      return2 c~ ((λ cᵢ' → when (cᵢ =ℕ cᵢ') eᵢ) , (maybe-not (asₗ cᵢ) >> just cᵢ))
    _ →
      [- Var-span Γ pi x untyped [] (just $ "This is not a valid constructor name") -]
      return2 (Case x cas~ t~ []) (asₗ , nothing)


import cedille-options
open import general-util
module meta-vars (options : cedille-options.options) {mF : Set → Set} ⦃ _ : monad mF ⦄ where

open import cedille-types
open import constants
open import conversion
open import ctxt
open import free-vars
open import rename
open import spans options {mF}
open import subst
open import syntax-util
open import to-string options

-- misc
----------------------------------------------------------------------

-- Meta-variables, prototypes, decorated types
-- ==================================================

record meta-var-sol (A : Set) : Set where
  constructor mk-meta-var-sol
  field
    sol : A
    src : checking-mode

data meta-var-sort : Set where
  meta-var-tp : (k  : kind) → (mtp : maybe $ meta-var-sol type) → meta-var-sort
  meta-var-tm : (tp : type) → (mtm : maybe $ meta-var-sol term) → meta-var-sort

record meta-var : Set where
  constructor meta-var-mk
  field
    name : string
    sort  : meta-var-sort
    loc  : span-location
open meta-var

pattern meta-var-mk-tp x k mtp l = meta-var-mk x (meta-var-tp k mtp) l

record meta-vars : Set where
  constructor meta-vars-mk
  field
    order   : 𝕃 var
    varset  : trie meta-var
open meta-vars

data prototype : Set where
  proto-maybe : maybe type → prototype
  proto-arrow : erased? → prototype → prototype

data decortype : Set where
  decor-type  : type → decortype
  decor-arrow : erased? → type → decortype → decortype
  decor-decor : erased? → var → tpkd → meta-var-sort → decortype → decortype
  decor-stuck : type → prototype → decortype
  decor-error : type → prototype → decortype

-- Simple definitions and accessors
-- --------------------------------------------------

meta-var-name : meta-var → var
meta-var-name X = meta-var.name X

meta-vars-get-varlist : meta-vars → 𝕃 var
meta-vars-get-varlist Xs = map (name ∘ snd) (trie-mappings (varset Xs))

meta-var-solved? : meta-var → 𝔹
meta-var-solved? (meta-var-mk n (meta-var-tp k nothing) _) = ff
meta-var-solved? (meta-var-mk n (meta-var-tp k (just _)) _) = tt
meta-var-solved? (meta-var-mk n (meta-var-tm tp nothing) _) = ff
meta-var-solved? (meta-var-mk n (meta-var-tm tp (just _)) _) = tt

meta-vars-empty : meta-vars
meta-vars-empty = meta-vars-mk [] empty-trie

meta-vars-empty? : meta-vars → 𝔹
meta-vars-empty? Xs = ~ (trie-nonempty (varset Xs ))

meta-vars-solved? : meta-vars → 𝔹
meta-vars-solved? Xs = trie-all meta-var-solved? (varset Xs)

meta-vars-filter : (meta-var → 𝔹) → meta-vars → meta-vars
meta-vars-filter f Xs =
  meta-vars-mk or vs
  where
  vs = trie-filter f (varset Xs)
  or = filter (trie-contains vs) (order Xs)

meta-var-sort-eq? : ctxt → (=S =T : meta-var-sort) → 𝔹
meta-var-sort-eq? Γ (meta-var-tp k₁ mtp₁) (meta-var-tp k₂ mtp₂)
  with conv-kind Γ k₁ k₂
... | ff = ff
... | tt =
  maybe-equal? sol-eq mtp₁ mtp₂
  where
    sol-eq : (sol₁ sol₂ : meta-var-sol type) → 𝔹
    sol-eq (mk-meta-var-sol sol₁ src) (mk-meta-var-sol sol₂ src₁) =
      conv-type Γ sol₁ sol₂

meta-var-sort-eq? _ _ _ = ff
-- TODO terms not supported
-- meta-var-sol-eq? (meta-var-tm tp mtm) (meta-var-tm tp₁ mtm₁) = {!!}

meta-var-equal? : ctxt → (X Y : meta-var) → 𝔹
meta-var-equal? Γ (meta-var-mk name₁ sol₁ _) (meta-var-mk name₂ sol₂ _) =
  name₁ =string name₂ && meta-var-sort-eq? Γ sol₁ sol₂

meta-vars-equal? : ctxt → (Xs Ys : meta-vars) → 𝔹
meta-vars-equal? Γ Xs Ys =
  trie-equal? (meta-var-equal? Γ) (meta-vars.varset Xs) (meta-vars.varset Ys)

meta-vars-lookup : meta-vars → var → maybe meta-var
meta-vars-lookup Xs x = trie-lookup (varset Xs) x

meta-vars-lookup-with-kind : meta-vars → var → maybe (meta-var × kind)
meta-vars-lookup-with-kind Xs x
  with meta-vars-lookup Xs x
... | nothing = nothing
... | (just X@(meta-var-mk-tp _ k _ _)) = just $ X , k
... | (just X) = nothing

meta-var-set-src : meta-var → checking-mode → meta-var
meta-var-set-src (meta-var-mk-tp name₁ k (just sol) loc₁) m =
  meta-var-mk-tp name₁ k (just (record sol { src = m })) loc₁
meta-var-set-src (meta-var-mk-tp name₁ k nothing loc₁) m =
  meta-var-mk-tp name₁ k nothing loc₁
meta-var-set-src (meta-var-mk name₁ (meta-var-tm tp (just sol)) loc₁) m =
  meta-var-mk name₁ (meta-var-tm tp (just (record sol { src = m }))) loc₁
meta-var-set-src (meta-var-mk name₁ (meta-var-tm tp nothing) loc₁) m
  = meta-var-mk name₁ (meta-var-tm tp nothing) loc₁

meta-vars-lookup-kind : meta-vars → var → maybe kind
meta-vars-lookup-kind Xs x with meta-vars-lookup Xs x
... | nothing = nothing
... | (just (meta-var-mk-tp _ k _ _)) = just k
... | (just X) = nothing

-- conversion to types, terms, tks
-- --------------------------------------------------

meta-var-sort-to-tk : meta-var-sort → tpkd
meta-var-sort-to-tk (meta-var-tp k mtp) = Tkk k
meta-var-sort-to-tk (meta-var-tm tp mtm) = Tkt tp

meta-var-to-type : meta-var → maybe type
meta-var-to-type (meta-var-mk-tp x k (just tp) _) = just (meta-var-sol.sol tp)
meta-var-to-type (meta-var-mk-tp x k nothing _) = just (TpVar x)
meta-var-to-type (meta-var-mk x (meta-var-tm tp mtm) _) = nothing

meta-var-to-term : meta-var → maybe term
meta-var-to-term (meta-var-mk-tp x k mtp _) = nothing
meta-var-to-term (meta-var-mk x (meta-var-tm tp (just tm)) _) = just (meta-var-sol.sol tm)
meta-var-to-term (meta-var-mk x (meta-var-tm tp nothing) _) = just (Var x)

meta-var-to-type-unsafe : meta-var → type
meta-var-to-type-unsafe X
  with meta-var-to-type X
... | just tp = tp
... | nothing = TpVar (meta-var-name X)

meta-var-to-term-unsafe : meta-var → term
meta-var-to-term-unsafe X
  with meta-var-to-term X
... | just tm = tm
... | nothing = Var (meta-var-name X)

-- if all meta-vars are solved, return their solutions as args
meta-vars-to-args : meta-vars → maybe args
meta-vars-to-args (meta-vars-mk or vs) =
  flip 𝕃maybe-map or λ x → trie-lookup vs x ≫=maybe λ where
    (meta-var-mk name (meta-var-tm tp tm?) loc) →
      tm? >>= just ∘' ArgEr ∘' meta-var-sol.sol
    (meta-var-mk name (meta-var-tp kd tp?) loc) →
      tp? >>= just ∘' ArgTp ∘' meta-var-sol.sol

prototype-to-maybe : prototype → maybe type
prototype-to-maybe (proto-maybe mtp) = mtp
prototype-to-maybe (proto-arrow _ _) = nothing

prototype-to-checking : prototype → checking-mode
prototype-to-checking = maybe-to-checking ∘ prototype-to-maybe

decortype-to-type : decortype → type
decortype-to-type (decor-type tp) = tp
decortype-to-type (decor-arrow at tp dt) =
  TpArrow tp at (decortype-to-type dt)
decortype-to-type (decor-decor b x tk sol dt) =
  TpAbs b x tk (decortype-to-type dt)
decortype-to-type (decor-stuck tp pt) = tp
decortype-to-type (decor-error tp pt) = tp

-- hnf for decortype
-- --------------------------------------------------

hnf-decortype : ctxt → unfolding → decortype → (is-head : 𝔹) → decortype
hnf-decortype Γ uf (decor-type tp) ish =
  decor-type (hnf Γ (record uf {unfold-defs = ish}) tp)
hnf-decortype Γ uf (decor-arrow e? tp dt) ish =
  decor-arrow e? (hnf Γ (record uf {unfold-defs = ff}) tp) (hnf-decortype Γ uf dt ff)
hnf-decortype Γ uf (decor-decor e? x tk sol dt) ish =
  decor-decor e? x tk sol (hnf-decortype Γ uf dt ff)
hnf-decortype Γ uf dt@(decor-stuck _ _) ish = dt
hnf-decortype Γ uf (decor-error tp pt) ish =
  decor-error (hnf Γ (record uf {unfold-defs = ff}) tp) pt

-- substitutions
-- --------------------------------------------------

substh-meta-var-sort : substh-ret-t meta-var-sort
substh-meta-var-sort Γ ρ σ (meta-var-tp k mtp) =
  meta-var-tp (substh Γ ρ σ k) ((flip maybe-map) mtp λ sol →
    record sol { sol = substh Γ ρ σ (meta-var-sol.sol sol) })
substh-meta-var-sort Γ ρ σ (meta-var-tm tp mtm) =
  meta-var-tm (substh Γ ρ σ tp) (flip maybe-map mtm λ sol →
    record sol { sol = substh Γ ρ σ (meta-var-sol.sol sol) })

subst-meta-var-sort : subst-ret-t meta-var-sort
subst-meta-var-sort Γ t x (meta-var-tp k mtp) =
  meta-var-tp (subst Γ t x k) $ (flip maybe-map) mtp λ sol →
    record sol { sol = subst Γ t x $ meta-var-sol.sol sol }

subst-meta-var-sort Γ t x (meta-var-tm tp mtm) =
  meta-var-tm (subst Γ t x tp) $ (flip maybe-map) mtm λ where
    (mk-meta-var-sol sol src) → mk-meta-var-sol (subst Γ t x sol) src

meta-vars-get-sub : meta-vars → trie (Σi exprd ⟦_⟧)
meta-vars-get-sub Xs =
  trie-catMaybe (trie-map (maybe-map ,_ ∘ meta-var-to-type) (varset Xs))

meta-vars-subst-type' : (unfold : 𝔹) → ctxt → meta-vars → type → type
meta-vars-subst-type' u Γ Xs tp =
  let tp' = substs Γ (meta-vars-get-sub Xs) tp in
  if u then hnf Γ unfold-head-elab tp' else tp'

meta-vars-subst-type : ctxt → meta-vars → type → type
meta-vars-subst-type = meta-vars-subst-type' tt

meta-vars-subst-kind : ctxt → meta-vars → kind → kind
meta-vars-subst-kind Γ Xs k
  = hnf Γ unfold-head-elab (substh Γ empty-renamectxt (meta-vars-get-sub Xs) k)

-- string and span helpers
-- --------------------------------------------------

meta-var-to-string : meta-var → strM
meta-var-to-string (meta-var-mk-tp name k nothing sl)
  = strMetaVar name sl
    >>str strAdd " : " >>str to-stringe k
meta-var-to-string (meta-var-mk-tp name k (just tp) sl)
  = strMetaVar name sl
    >>str strAdd " : " >>str to-stringe k
    >>str strAdd " = " >>str to-stringe (meta-var-sol.sol tp) -- tp
meta-var-to-string (meta-var-mk name (meta-var-tm tp nothing) sl)
  = strMetaVar name sl
    >>str strAdd " : " >>str to-stringe tp
meta-var-to-string (meta-var-mk name (meta-var-tm tp (just tm)) sl)
  = strMetaVar name sl
    >>str strAdd " : " >>str to-stringe tp
    >>str strAdd " = " >>str to-stringe (meta-var-sol.sol tm) -- tm

meta-vars-to-stringe : 𝕃 meta-var → strM
meta-vars-to-stringe []
  = strEmpty
meta-vars-to-stringe (v :: [])
  = meta-var-to-string v
meta-vars-to-stringe (v :: vs)
  = meta-var-to-string v >>str strAdd ", " >>str meta-vars-to-stringe vs

meta-vars-to-string : meta-vars → strM
meta-vars-to-string Xs =
  meta-vars-to-stringe
    ((flip map) (order Xs) λ x →
      case trie-lookup (varset Xs) x of λ where
        nothing  →
          meta-var-mk
            (x ^ "-missing!") (meta-var-tp KdStar nothing)
            missing-span-location
        (just X) → X)

prototype-to-string : prototype → strM
prototype-to-string (proto-maybe nothing) = strAdd "⁇"
prototype-to-string (proto-maybe (just tp)) = to-stringe tp
prototype-to-string (proto-arrow e? pt) =
  strAdd "⁇" >>str strAdd (arrowtype-to-string e?)
  >>str prototype-to-string pt

decortype-to-string : decortype → strM
decortype-to-string (decor-type tp) =
  strAdd "[" >>str to-stringe tp >>str strAdd "]"
decortype-to-string (decor-arrow e? tp dt) =
  to-stringe tp
  >>str strAdd (arrowtype-to-string e?)
  >>str decortype-to-string dt
decortype-to-string (decor-decor e? x tk sol dt) =
  strAdd (binder e? sol) >>str meta-var-to-string (meta-var-mk x sol missing-span-location)
  >>str strAdd "<" >>str tpkd-to-stringe tk >>str strAdd ">" >>str strAdd " . " >>str decortype-to-string dt
  where
  binder : erased? → meta-var-sort → string
  binder Erased sol = "∀ "
  binder Pi (meta-var-tm tp mtm) = "Π "
  -- vv clause below "shouldn't" happen
  binder Pi (meta-var-tp k mtp) = "∀ "

decortype-to-string (decor-stuck tp pt) =
  strAdd "(" >>str to-stringe tp >>str strAdd " , " >>str prototype-to-string pt >>str strAdd ")"
decortype-to-string (decor-error tp pt) =
  strAdd "([" >>str (to-stringe tp) >>str strAdd "] ‼ " >>str prototype-to-string pt >>str strAdd ")"

meta-vars-data-h : ctxt → string → kind ∨ (meta-var-sol type) → tagged-val
meta-vars-data-h Γ X (inj₁ k) =
  strRunTag "meta-vars-intro" Γ
    (strAdd (unqual-local X ^ "  ") >>str to-stringe k)
meta-vars-data-h Γ X (inj₂ sol) =
  strRunTag "meta-vars-sol" Γ $
  strAdd (unqual-local X ^ " ") >>str
  strAdd (checking-to-string (meta-var-sol.src sol) ^ " ") >>str
  (to-stringe ∘ meta-var-sol.sol $ sol)

meta-vars-data-all : ctxt → meta-vars → 𝕃 tagged-val
meta-vars-data-all Γ = foldr
  (uncurry λ where
    _ (meta-var-mk X (meta-var-tp kd nothing) loc) xs →
      meta-vars-data-h Γ X (inj₁ kd) :: xs
    _ (meta-var-mk X (meta-var-tp kd (just tp)) loc) xs →
      meta-vars-data-h Γ X (inj₁ kd)
      :: meta-vars-data-h Γ X (inj₂ tp) :: xs
    _ _ xs → xs)
  [] ∘ (trie-mappings ∘ meta-vars.varset)

meta-vars-intro-data : ctxt → meta-vars → 𝕃 tagged-val
meta-vars-intro-data Γ = map (h ∘ snd) ∘ (trie-mappings ∘ meta-vars.varset)
  where
  h : meta-var → tagged-val
  h (meta-var-mk X (meta-var-tp kd mtp) loc) = meta-vars-data-h Γ X (inj₁ kd)
  h (meta-var-mk X (meta-var-tm tp mtm) loc) =
    meta-vars-data-h Γ X
      (inj₂ (mk-meta-var-sol (TpVar "unimplemented") untyped))

meta-vars-sol-data : ctxt → meta-vars → meta-vars → 𝕃 tagged-val
meta-vars-sol-data Γ Xsₒ Xsₙ = foldr (λ X xs → maybe-else xs (_:: xs) (h (snd X)))
  [] (trie-mappings (meta-vars.varset Xsₙ))
  where
  h : meta-var → maybe tagged-val
  h (meta-var-mk X (meta-var-tp kd (just tp)) loc) with trie-lookup (meta-vars.varset Xsₒ) X
  ...| just (meta-var-mk _ (meta-var-tp _ (just _)) _) = nothing
  ...| _ = just (meta-vars-data-h Γ X (inj₂ tp)
    )
  h (meta-var-mk X (meta-var-tp kd nothing) loc) = nothing
  h (meta-var-mk X (meta-var-tm tp mtm) loc) =
    just (meta-vars-data-h Γ X
      (inj₂ (mk-meta-var-sol (TpVar "unimplemented") untyped)))

meta-vars-check-type-mismatch : ctxt → string → type → meta-vars → type
                                 → 𝕃 tagged-val × err-m
meta-vars-check-type-mismatch Γ s tp Xs tp'
  = (expected-type Γ tp :: [ type-data Γ tp'' ]) ,
    (if conv-type Γ tp tp''
        then nothing
        else just ("The expected type does not match the "
               ^ s ^ " type."))
    where tp'' = meta-vars-subst-type' ff Γ Xs tp'

meta-vars-check-type-mismatch-if : maybe type → ctxt → string → meta-vars
                                    → type → 𝕃 tagged-val × err-m
meta-vars-check-type-mismatch-if (just tp) Γ s Xs tp'
  = meta-vars-check-type-mismatch Γ s tp Xs tp'
meta-vars-check-type-mismatch-if nothing Γ s Xs tp'
  = [ type-data Γ tp″ ] , nothing
  where
  tp″ = meta-vars-subst-type' ff Γ Xs tp'

decortype-data : ctxt → decortype → tagged-val
decortype-data Γ dt = strRunTag "head decoration" Γ (decortype-to-string dt)

prototype-data : ctxt → prototype → tagged-val
prototype-data Γ pt = strRunTag "head prototype" Γ (prototype-to-string pt)

-- collecting, merging, matching
-- --------------------------------------------------

meta-var-fresh-t : (S : Set) → Set
meta-var-fresh-t S = meta-vars → var → span-location → S → meta-var

meta-var-fresh : meta-var-fresh-t meta-var-sort
meta-var-fresh Xs x sl sol
  with fresh-h (trie-contains (varset Xs)) (meta-var-pfx-str ^ x)
... | x' = meta-var-mk x' sol sl

meta-var-fresh-tp : meta-var-fresh-t (kind × maybe (meta-var-sol type))
meta-var-fresh-tp Xs x sl (k , msol) =
  meta-var-fresh Xs x sl (meta-var-tp k msol)

meta-var-fresh-tm : meta-var-fresh-t (type × maybe (meta-var-sol term))
meta-var-fresh-tm Xs x sl (tp , mtm) = meta-var-fresh Xs x sl (meta-var-tm tp mtm)

private
  meta-vars-set : meta-vars → meta-var → meta-vars
  meta-vars-set Xs X = record Xs { varset = trie-insert (varset Xs) (name X) X }

-- add a meta-var
meta-vars-add : meta-vars → meta-var → meta-vars
meta-vars-add Xs X
 = record (meta-vars-set Xs X) { order = (order Xs) ++ [ name X ] }

meta-vars-add* : meta-vars → 𝕃 meta-var → meta-vars
meta-vars-add* Xs [] = Xs
meta-vars-add* Xs (Y :: Ys) = meta-vars-add* (meta-vars-add Xs Y) Ys

meta-vars-from-list : 𝕃 meta-var → meta-vars
meta-vars-from-list Xs = meta-vars-add* meta-vars-empty Xs

meta-vars-remove : meta-vars → meta-var → meta-vars
meta-vars-remove (meta-vars-mk or vs) X =
  let x = meta-var-name X
  in meta-vars-mk (remove _=string_ x or) (trie-remove vs x)

meta-vars-in-type : meta-vars → type → meta-vars
meta-vars-in-type Xs tp =
  let xs = free-vars tp in
  meta-vars-filter (stringset-contains xs ∘ name) Xs

meta-vars-unsolved : meta-vars → meta-vars
meta-vars-unsolved = meta-vars-filter λ where
  (meta-var-mk x (meta-var-tp k mtp) _)  → ~ isJust mtp
  (meta-var-mk x (meta-var-tm tp mtm) _) → ~ isJust mtm

meta-vars-are-free-in-type : meta-vars → type → 𝔹
meta-vars-are-free-in-type Xs tp =
  let xs = free-vars tp in
  list-any (stringset-contains xs) (order Xs)

-- Unfolding a type with meta-vars
-- ==================================================

-- ... in order to reveal a term or type application

-- "View" data structures
-- --------------------------------------------------

-- The decorated type is really an arrow
record is-tmabsd : Set where
  constructor mk-tmabsd
  field
    is-tmabsd-dt  : decortype
    is-tmabsd-e?  : erased?
    is-tmabsd-var : var
    is-tmabsd-dom : type
    is-tmabsd-var-in-body : 𝔹
    is-tmabsd-cod : decortype
open is-tmabsd public

is-tmabsd? = decortype ∨ is-tmabsd

pattern yes-tmabsd dt e? x dom occ cod = inj₂ (mk-tmabsd dt e? x dom occ cod)
pattern not-tmabsd tp = inj₁ tp

record is-tpabsd : Set where
  constructor mk-tpabsd
  field
    is-tpabsd-dt   : decortype
    is-tpabsd-e?   : erased?
    is-tpabsd-var  : var
    is-tpabsd-kind : kind
    is-tpabsd-sol  : maybe type
    is-tpabsd-body : decortype
open is-tpabsd public

is-tpabsd? = decortype ∨ is-tpabsd

pattern yes-tpabsd dt e? x k mtp dt' = inj₂ (mk-tpabsd dt e? x k mtp dt')
pattern not-tpabsd dt = inj₁ dt

{-# TERMINATING #-}
num-arrows-in-type : ctxt → type → ℕ
num-arrows-in-type Γ tp = nait Γ (hnf' Γ tp) 0 tt
  where
  hnf' : ctxt → type → type
  hnf' Γ tp = hnf Γ unfold-head-elab tp

  nait : ctxt → type → (acc : ℕ) → 𝔹 → ℕ
  -- definitely another arrow
  nait Γ (TpAbs _ _ (Tkk _) tp) acc uf = nait Γ tp acc ff
  nait Γ (TpAbs _ _ (Tkt _) tp) acc uf = nait Γ tp (1 + acc) ff
  -- definitely not another arrow
  nait Γ (TpIota _ _ _) acc uf = acc
  nait Γ (TpEq _ _) acc uf = acc
  nait Γ (TpHole _) acc uf = acc
  nait Γ (TpLam _ _ _) acc uf = acc
  nait Γ (TpVar x) acc tt = acc
  nait Γ (TpApp tp₁ tp₂) acc tt = acc
  nait Γ tp acc ff = nait Γ (hnf' Γ tp) acc tt

-- Utilities for match-types in classify.agda
-- ==================================================
--
-- Match a type with meta-variables in it to one without

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

match-error-data = string × 𝕃 tagged-val

match-error-t : ∀ {a} → Set a → Set a
match-error-t A = match-error-data ∨ A

pattern match-error e = inj₁ e
pattern match-ok a = inj₂ a

module meta-vars-match-errors where
  -- boilerplate
  match-error-msg = "Matching failed"

  -- tagged values for error messages
  match-lhs : {ed : exprd} → ctxt → ⟦ ed ⟧ → tagged-val
  match-lhs = to-string-tag "expected lhs"

  match-rhs : {ed : exprd} → ctxt → ⟦ ed ⟧ → tagged-val
  match-rhs = to-string-tag "computed rhs"

  the-meta-var : var → tagged-val
  the-meta-var = strRunTag "the meta-var" empty-ctxt ∘ strAdd

  the-solution : ctxt → type → tagged-val
  the-solution = to-string-tag "the solution"

  fst-snd-sol : {ed : exprd} → ctxt → (t₁ t₂ : ⟦ ed ⟧) → 𝕃 tagged-val
  fst-snd-sol Γ t₁ t₂ =
    to-string-tag "first solution" Γ t₁ :: [ to-string-tag "second solution" Γ t₂ ]

  lhs-rhs : {ed : exprd} → ctxt → (t₁ t₂ : ⟦ ed ⟧) → 𝕃 tagged-val
  lhs-rhs Γ t₁ t₂ = match-lhs Γ t₁ :: [ match-rhs Γ t₂ ]

  -- error-data
  e-solution-ineq : ctxt → (tp₁ tp₂ : type) → var → match-error-data
  e-solution-ineq Γ tp₁ tp₂ X =
    match-error-msg ^ " because it produced two incovertible solutions for a meta-variable"
    , the-meta-var X :: fst-snd-sol Γ tp₁ tp₂

  e-match-failure : match-error-data
  e-match-failure =
    "The expected argument type is not a (first-order) match of the computed type"
    , []

  e-matchk-failure : match-error-data
  e-matchk-failure =
    "The expected argument kind is not a (first-order) match of the computed kind"
    , []

  e-meta-scope : ctxt → (X tp : type) → match-error-data
--  e-meta-scope : ctxt → (x : var) → (tp₁ tp₂ : type) → match-error-data
  e-meta-scope Γ X tp =
    match-error-msg ^ " because the solution contains a bound variable of the computed argument type"
    , to-string-tag "the meta var" Γ X :: [ to-string-tag "the solution" Γ tp ]

  e-bad-sol-kind : ctxt → (X : var) → (sol : type) → match-error-data
  e-bad-sol-kind Γ X sol =
    "The meta-variable was matched to a type whose kind does not match its own"
    , the-meta-var X :: [ the-solution Γ sol ]

open meta-vars-match-errors

-- meta-vars-match auxiliaries
-- --------------------------------------------------

local-vars = stringset

meta-vars-solve-tp : ctxt → meta-vars → var → type → checking-mode → match-error-t meta-vars
meta-vars-solve-tp Γ Xs x tp m with trie-lookup (varset Xs) x
... | nothing
  = match-error $ x ^ " is not a meta-var!" , []
... | just (meta-var-mk _ (meta-var-tm tp' mtm) _)
  = match-error $ x ^ " is a term meta-var!" , []
... | just (meta-var-mk-tp _ k nothing sl)
  = match-ok (meta-vars-set Xs (meta-var-mk-tp x k (just (mk-meta-var-sol tp m)) sl))
... | just (meta-var-mk-tp _ k (just sol) _) =
  let mk-meta-var-sol tp' src = sol in
  err⊎-guard (~ conv-type Γ tp tp') (e-solution-ineq Γ tp tp x)
  >> match-ok Xs

-- update the kinds of HO meta-vars with
-- solutions
meta-vars-update-kinds : ctxt → (Xs Xsₖ : meta-vars) → meta-vars
meta-vars-update-kinds Γ Xs Xsₖ =
  record Xs { varset = (flip trie-map) (varset Xs) λ where
    (meta-var-mk-tp x k mtp sl) → meta-var-mk-tp x (meta-vars-subst-kind Γ Xsₖ k) mtp sl
    sol → sol
  }

hnf-elab-if : {ed : exprd} → 𝔹 → ctxt → ⟦ ed ⟧ → 𝔹 → ⟦ ed ⟧
hnf-elab-if b Γ t b' = if b then hnf Γ (record unfold-head-elab {unfold-defs = b'}) t else t

meta-vars-add-from-tpabs : ctxt → span-location → meta-vars → erased? → var → kind → type → meta-var × meta-vars
meta-vars-add-from-tpabs Γ sl Xs e? x k tp =
  let Y   = meta-var-fresh-tp Xs x sl (k , nothing)
      Xs' = meta-vars-add Xs Y
--      tp' = subst Γ (meta-var-to-type-unsafe Y) x tp
  in Y , Xs'

{-
-- Legacy for elaboration.agda
-- ==================================================

-- TODO: remove dependency and delete code

{-# TERMINATING #-} -- subst of a meta-var does not increase distance to arrow
meta-vars-peel : ctxt → span-location → meta-vars → type → (𝕃 meta-var) × type
meta-vars-peel Γ sl Xs (Abs pi e? pi' x tk@(Tkk k) tp)
  with meta-vars-add-from-tpabs Γ sl Xs (mk-tpabs e? x k tp)
... | (Y , Xs')
  with subst Γ (meta-var-to-type-unsafe Y) x tp
... | tp' =
  let ret =  meta-vars-peel Γ sl Xs' tp' ; Ys  = fst ret ; rtp = snd ret
  in (Y :: Ys , rtp)
meta-vars-peel Γ sl Xs (NoSpans tp _) =
  meta-vars-peel Γ sl Xs tp
meta-vars-peel Γ sl Xs (TpParens _ tp _) =
  meta-vars-peel Γ sl Xs tp
meta-vars-peel Γ sl Xs tp = [] , tp

meta-vars-unfold-tpapp : ctxt → meta-vars → type → is-tpabs?
meta-vars-unfold-tpapp Γ Xs tp
  with meta-vars-subst-type Γ Xs tp
... | Abs _ b _ x (Tkk k) tp' = yes-tpabs b x k tp'
... | tp'                        = not-tpabs tp'

meta-vars-unfold-tmapp : ctxt → span-location → meta-vars → type → 𝕃 meta-var × is-tmabs?
meta-vars-unfold-tmapp Γ sl Xs tp
  with meta-vars-peel Γ sl Xs (meta-vars-subst-type Γ Xs tp)
... | Ys , Abs _ b _ x (Tkt dom) cod =
  Ys , yes-tmabs b x dom (is-free-in check-erased x cod) cod
... | Ys , TpArrow dom e? cod =
  Ys , yes-tmabs e? "_" dom ff cod
... | Ys , tp' = Ys , not-tmabs tp'

-}


module Issue326 where

open import Common.Prelude
open import Common.MAlonzo using () -- see issue 561

postulate
  QName : Set
  printBool : Bool → IO Unit

{-# BUILTIN QNAME QName #-}
{-# COMPILED printBool print #-}

primitive primQNameEquality : QName → QName → Bool

main : IO Unit
main = printBool (primQNameEquality (quote Unit) (quote IO))