open import Nat
open import Prelude
open import dynamics-core
open import contexts
open import lemmas-consistency
open import lemmas-ground

open import progress-checks

open import canonical-boxed-forms
open import canonical-value-forms
open import canonical-indeterminate-forms

open import ground-decidable
open import htype-decidable

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress
  data ok : (d : ihexp) (Δ : hctx) → Set where
    S  : ∀{d Δ} → Σ[ d' ∈ ihexp ] (d ↦ d') → ok d Δ
    I  : ∀{d Δ} → d indet → ok d Δ
    BV : ∀{d Δ} → d boxedval → ok d Δ

  progress : {Δ : hctx} {d : ihexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
    -- constants
  progress TANum = BV (BVVal VNum)

    -- addition
  progress (TAPlus wt1 wt2) with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  ... | S (_ , Step x y z) | _  = S (_ , Step (FHPlus1 x) y (FHPlus1 z))
  ... | I _ | S (_ , Step x y z) = S (_ , Step (FHPlus2 x) y (FHPlus2 z))
  ... | BV _ | S (_ , Step x y z) = S (_ , Step (FHPlus2 x) y (FHPlus2 z))
  ... | I x | I x₁ = I (IPlus1 x (FIndet x₁))
  ... | I x | BV x₁ = I (IPlus1 x (FBoxedVal x₁))
  ... | BV (BVVal VNum) | I x = I (IPlus2 (FBoxedVal (BVVal VNum)) x)
  ... | BV (BVVal VNum) | BV (BVVal VNum) = S (_ , Step FHOuter (ITPlus refl) FHOuter)

    -- variables
  progress (TAVar x₁) = abort (somenotnone (! x₁))

    -- lambdas
  progress (TALam _ wt) = BV (BVVal VLam)

    -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  ... | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z))
    -- if the left is indeterminate, step the right
  ... | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2  z))
    -- if they're both indeterminate, step when the cast steps and indet otherwise
  ... | I x | I y
    with canonical-indeterminate-forms-arr wt1 x
  ... | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter)
  ... | CIFAEHole (_ , _ , _ , refl , _)             = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  ... | CIFANEHole (_ , _ , _ , _ , _ , refl , _)    = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  ... | CIFAAp (_ , _ , _ , _ , _ , refl , _)        = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  ... | CIFACastHole (_ , refl , refl , refl , _ )   = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  ... | CIFAFailedCast (_ , _ , refl , _ )           = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  ... | CIFACase (_ , _ , _ , _ , _ , _ , _ , refl , _ ) = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  ... | CIFAFst (_ , _ , refl , _ , _ , _ , _) = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  ... | CIFASnd (_ , _ , refl , _ , _ , _ , _) = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))

    -- similar if the left is indeterminate but the right is a boxed val
  progress (TAAp wt1 wt2) | I x | BV y
    with canonical-indeterminate-forms-arr wt1 x
  ... | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter)
  ... | CIFAEHole (_ , _ , _ , refl , _)             = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y))
  ... | CIFANEHole (_ , _ , _ , _ , _ , refl , _)    = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y))
  ... | CIFAAp (_ , _ , _ , _ , _ , refl , _)        = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y))
  ... | CIFACastHole (_ , refl , refl , refl , _ )   = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y))
  ... | CIFAFailedCast (_ , _ , refl , _ )           = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y))
  ... | CIFACase (_ , _ , _ , _ , _ , _ , _ , refl , _ ) = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y))
  ... | CIFAFst (_ , _ , refl , _ , _ , _ , _) = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y))
  ... | CIFASnd (_ , _ , refl , _ , _ , _ , _) = I (IAp (λ _ _ _ _ _ ()) x (FBoxedVal y))

    -- if the left is a boxed value, inspect the right
  progress (TAAp wt1 wt2) | BV v | S (_ , Step x y z) = S (_ , Step (FHAp2  x) y (FHAp2  z))
  progress (TAAp wt1 wt2) | BV v | I i
    with canonical-boxed-forms-arr wt1 v
  ... | CBFALam (_ , _ , refl , _)             = S (_ , Step FHOuter ITLam FHOuter)
  ... | CBFACastArr (_ , _ , _ , refl , _ , _) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | BV v | BV v₂
    with canonical-boxed-forms-arr wt1 v
  ... | CBFALam (_ , _ , refl , _)             = S (_ , Step FHOuter ITLam FHOuter)
  ... | CBFACastArr (_ , _ , _ , refl , _ , _) = S (_ , Step FHOuter ITApCast FHOuter)

    -- sum types
  progress (TAInl wt)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHInl x) y (FHInl z))
  ... | I x = I (IInl x)
  ... | BV x = BV (BVInl x)
  progress (TAInr wt)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHInr x) y (FHInr z))
  ... | I x = I (IInr x)
  ... | BV x = BV (BVInr x)
  progress (TACase wt _ wt₁ _ wt₂)
    with progress wt
  ... | S (_ , Step x y z)  = S (_ , Step (FHCase x) y (FHCase z))
  progress (TACase () _ wt₁ _ wt₂) | BV (BVVal VNum)
  progress (TACase () _ wt₁ _ wt₂) | BV (BVVal VLam)
  progress (TACase () _ wt₁ _ wt₂) | BV (BVVal (VPair x x₁))
  progress (TACase wt _ wt₁ _ wt₂) | BV (BVVal (VInl x)) = S (_ , Step FHOuter ITCaseInl FHOuter)
  ... | BV (BVVal (VInr x)) = S (_ , Step FHOuter ITCaseInr FHOuter)
  ... | BV (BVInl x)        = S (_ , Step FHOuter ITCaseInl FHOuter)
  ... | BV (BVInr x)        = S (_ , Step FHOuter ITCaseInr FHOuter)
  ... | BV (BVSumCast x x₁) = S (_ , Step FHOuter ITCaseCast FHOuter)
  ... | I (IAp x x₁ x₂) = I (ICase (λ _ _ ()) (λ _ _ ()) (λ _ _ _ _ _ ()) (IAp x x₁ x₂))
  ... | I (IInl x) = S (_ , Step FHOuter ITCaseInl FHOuter)
  ... | I (IInr x) = S (_ , Step FHOuter ITCaseInr FHOuter)
  ... | I (ICase x x₁ x₂ x₃) = I (ICase (λ _ _ ()) (λ _ _ ()) (λ _ _ _ _ _ ()) (ICase x x₁ x₂ x₃))
  ... | I (IFst x x₁ x₂) = I (ICase (λ _ _ ()) (λ _ _ ()) (λ _ _ _ _ _ ()) (IFst x x₁ x₂))
  ... | I (ISnd x x₁ x₂) = I (ICase (λ _ _ ()) (λ _ _ ()) (λ _ _ _ _ _ ()) (ISnd x x₁ x₂))
  ... | I IEHole = I (ICase (λ _ _ ()) (λ _ _ ()) (λ _ _ _ _ _ ()) IEHole)
  ... | I (INEHole x) = I (ICase (λ _ _ ()) (λ _ _ ()) (λ _ _ _ _ _ ()) (INEHole x))
  ... | I (ICastSum x x₁) = S (_ , Step FHOuter ITCaseCast FHOuter)
  ... | I (ICastHoleGround x x₁ x₂) = I (ICase (λ _ _ ()) (λ _ _ ()) (λ _ _ _ _ _ ()) (ICastHoleGround x x₁ x₂))
  ... | I (IFailedCast x x₁ x₂ x₃) = I (ICase (λ _ _ ()) (λ _ _ ()) (λ _ _ _ _ _ ()) (IFailedCast x x₁ x₂ x₃))

    --product types
  progress (TAPair wt₁ wt₂)
    with progress wt₁ | progress wt₂
  ... | S (_ , Step x y z) | _  = S (_ , Step (FHPair1 x) y (FHPair1 z))
  ... | I _ | S (_ , Step x y z) = S (_ , Step (FHPair2 x) y (FHPair2 z))
  ... | BV _ | S (_ , Step x y z) = S (_ , Step (FHPair2 x) y (FHPair2 z))
  ... | I x | I x₁ = I (IPair1 x (FIndet x₁))
  ... | I x | BV x₁ = I (IPair1 x (FBoxedVal x₁))
  ... | BV x | I x₁ = I (IPair2 (FBoxedVal x) x₁)
  ... | BV x | BV x₁ = BV (BVPair x x₁)
  progress (TAFst wt)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHFst x) y (FHFst z))
  ... | I (IAp x x₁ x₂) = I (IFst (λ _ _ ()) (λ _ _ _ _ _()) (IAp x x₁ x₂))
  ... | I (ICase x x₁ x₂ x₃) = I (IFst (λ _ _ ()) (λ _ _ _ _ _ ()) (ICase x x₁ x₂ x₃))
  ... | I (IPair1 x x₁) = S (_ , Step FHOuter ITFstPair FHOuter)
  ... | I (IPair2 x x₁) = S (_ , Step FHOuter ITFstPair FHOuter)
  ... | I (IFst x x₁ x₂) = I (IFst (λ _ _ ()) (λ _ _ _ _ _ ()) (IFst x x₁ x₂))
  ... | I (ISnd x x₁ x₂) = I (IFst (λ _ _ ()) (λ _ _ _ _ _ ()) (ISnd x x₁ x₂))
  ... | I IEHole = I (IFst (λ _ _ ()) (λ _ _ _ _ _ ()) IEHole)
  ... | I (INEHole x) = I (IFst (λ _ _ ()) (λ _ _ _ _ _ ()) (INEHole x))
  ... | I (ICastProd x x₁) = S (_ , Step FHOuter ITFstCast FHOuter)
  ... | I (ICastHoleGround x x₁ x₂) = I (IFst (λ _ _ ()) (λ _ _ _ _ _ ()) (ICastHoleGround x x₁ x₂))
  ... | I (IFailedCast x x₁ x₂ x₃) = I (IFst (λ _ _ ()) (λ _ _ _ _ _ ()) (IFailedCast x x₁ x₂ x₃))
  ... | BV (BVVal (VPair x x₁)) = S (_ , Step FHOuter ITFstPair FHOuter)
  ... | BV (BVPair x x₁) = S (_ , Step FHOuter ITFstPair FHOuter)
  ... | BV (BVProdCast x x₁) = S (_ , Step FHOuter ITFstCast FHOuter)
  progress (TASnd wt)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHSnd x) y (FHSnd z))
  ... | I (IAp x x₁ x₂) = I (ISnd (λ _ _ ()) (λ _ _ _ _ _ ()) (IAp x x₁ x₂))
  ... | I (ICase x x₁ x₂ x₃) = I (ISnd (λ _ _ ()) (λ _ _ _ _ _ ()) (ICase x x₁ x₂ x₃))
  ... | I (IPair1 x x₁) = S (_ , Step FHOuter ITSndPair FHOuter)
  ... | I (IPair2 x x₁) = S (_ , Step FHOuter ITSndPair FHOuter)
  ... | I (IFst x x₁ x₂) = I (ISnd (λ _ _ ()) (λ _ _ _ _ _ ()) (IFst x x₁ x₂))
  ... | I (ISnd x x₁ x₂) = I (ISnd (λ _ _ ()) (λ _ _ _ _ _ ()) (ISnd x x₁ x₂))
  ... | I IEHole = I (ISnd (λ _ _ ()) (λ _ _ _ _ _ ()) IEHole)
  ... | I (INEHole x) = I (ISnd (λ _ _ ()) (λ _ _ _ _ _ ()) (INEHole x))
  ... | I (ICastProd x x₁) = S (_ , Step FHOuter ITSndCast FHOuter)
  ... | I (ICastHoleGround x x₁ x₂) = I (ISnd (λ _ _ ()) (λ _ _ _ _ _ ()) (ICastHoleGround x x₁ x₂))
  ... | I (IFailedCast x x₁ x₂ x₃) = I (ISnd (λ _ _ ()) (λ _ _ _ _ _ ()) (IFailedCast x x₁ x₂ x₃))
  ... | BV (BVVal (VPair x x₁)) = S (_ , Step FHOuter ITSndPair FHOuter)
  ... | BV (BVPair x x₁) = S (_ , Step FHOuter ITSndPair FHOuter)
  ... | BV (BVProdCast x x₁) = S (_ , Step FHOuter ITSndCast FHOuter)

    -- empty holes are indeterminate
  progress (TAEHole _ _ ) = I IEHole

    -- nonempty holes step if the innards step, indet otherwise
  progress (TANEHole xin wt x₁)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHNEHole x) y (FHNEHole z))
  ... | I  x = I (INEHole (FIndet x))
  ... | BV x = I (INEHole (FBoxedVal x))

    -- casts
  progress (TACast wt con)
    with progress wt
    -- step if the innards step
  ... | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z))
    -- if indet, inspect how the types in the cast are realted by consistency:
    -- if they're the same, step by ID
  progress (TACast wt TCRefl)  | I x = S (_ , Step FHOuter ITCastID FHOuter)
    -- if first type is hole
  progress (TACast {τ1 = τ1} wt TCHole1) | I x
    with τ1
  ... | num = I (ICastGroundHole GNum x)
  ... | ⦇-⦈ = S (_ , Step FHOuter ITCastID FHOuter)
  ... | τ11 ==> τ12
    with ground-decidable (τ11 ==> τ12)
  ... | Inl GArrHole = I (ICastGroundHole GArrHole x)
  ... | Inr y =  S (_ , Step FHOuter (ITGround (MGArr (π1 (ground-not-holes y)))) FHOuter)
  progress (TACast {τ1 = τ1} wt TCHole1) | I x | τ11 ⊕ τ12
    with ground-decidable (τ11 ⊕ τ12)
  ... | Inl GSumHole = I (ICastGroundHole GSumHole x)
  ... | Inr y =  S (_ , Step FHOuter (ITGround (MGSum (π1 (π2 (ground-not-holes y))))) FHOuter)
  progress (TACast {τ1 = τ1} wt TCHole1) | I x | τ11 ⊠ τ12
    with ground-decidable (τ11 ⊠ τ12)
  ... | Inl GProdHole = I (ICastGroundHole GProdHole x)
  ... | Inr y = S (_ , Step FHOuter (ITGround (MGProd (π2 (π2 (ground-not-holes y))))) FHOuter)
    -- if second type is hole
  progress (TACast wt (TCHole2 {num})) | I x
    with canonical-indeterminate-forms-hole wt x
  ... | CIFHEHole (_ , _ , _ , refl , f)           = I (ICastHoleGround (λ _ _ ()) x GNum)
  ... | CIFHNEHole (_ , _ , _ , _ , _ , refl , _ ) = I (ICastHoleGround (λ _ _ ()) x GNum)
  ... | CIFHAp (_ , _ , _ , refl , _ )             = I (ICastHoleGround (λ _ _ ()) x GNum)
  ... | CIFHCase (_ , _ , _ , _ , _ , _ , _ , refl , _ ) = I (ICastHoleGround (λ _ _ ()) x GNum)
  ... | CIFHFst (_ , _ , refl , _ , _ , _ , _)  = I (ICastHoleGround (λ _ _ ()) x GNum)
  ... | CIFHSnd (_ , _ , refl , _ , _ , _ , _)  = I (ICastHoleGround (λ _ _ ()) x GNum)
  ... | CIFHCast (_ , τ , refl , _ , grn , _)
    with htype-dec τ num
  ... | Inl refl = S (_ , Step FHOuter (ITCastSucceed grn ) FHOuter)
  ... | Inr y    = S (_ , Step FHOuter (ITCastFail grn GNum y) FHOuter)

  progress (TACast wt (TCHole2 {⦇-⦈}))| I x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt (TCHole2 {τ11 ==> τ12})) | I x
    with ground-decidable (τ11 ==> τ12)
  ... | Inr y = S (_ , Step FHOuter (ITExpand (MGArr (π1 (ground-not-holes y)))) FHOuter)
  ... | Inl GArrHole
    with canonical-indeterminate-forms-hole wt x
  ... | CIFHEHole (_ , _ , _ , refl , _)            = I (ICastHoleGround (λ _ _ ()) x GArrHole)
  ... | CIFHNEHole (_ , _ , _ , _ , _ , refl , _)   = I (ICastHoleGround (λ _ _ ()) x GArrHole)
  ... | CIFHAp (_ , _ , _ , refl , _ )              = I (ICastHoleGround (λ _ _ ()) x GArrHole)
  ... | CIFHCase (_ , _ , _ , _ , _ , _ , _ , refl , _ ) = I (ICastHoleGround (λ _ _ ()) x GArrHole)
  ... | CIFHFst (_ , _ , refl , _ , _ , _ , _) = I (ICastHoleGround (λ _ _ ()) x GArrHole)
  ... | CIFHSnd (_ , _ , refl , _ , _ , _ , _) = I (ICastHoleGround (λ _ _ ()) x GArrHole)
  ... | CIFHCast (_ , ._ , refl , _ , GNum , _)     = S (_ , Step FHOuter (ITCastFail GNum GArrHole (λ ())) FHOuter)
  ... | CIFHCast (_ , ._ , refl , _ , GArrHole , _) = S (_ , Step FHOuter (ITCastSucceed GArrHole) FHOuter)
  ... | CIFHCast (_ , _ , refl , _ , GSumHole , _)  = S (_ , Step FHOuter (ITCastFail GSumHole GArrHole (λ ())) FHOuter)
  ... | CIFHCast (_ , ._ , refl , _ , GProdHole , _) = S (_ , Step FHOuter (ITCastFail GProdHole GArrHole (λ ())) FHOuter)

  progress (TACast wt (TCHole2 {τ11 ⊕ τ12})) | I x
    with ground-decidable (τ11 ⊕ τ12)
  ... | Inr y = S (_ , Step FHOuter (ITExpand (MGSum (π1 (π2 (ground-not-holes y))))) FHOuter)
  ... | Inl GSumHole
    with canonical-indeterminate-forms-hole wt x
  ... | CIFHEHole (_ , _ , _ , refl , _)           = I (ICastHoleGround (λ _ _ ()) x GSumHole)
  ... | CIFHNEHole (_ , _ , _ , _ , _ , refl , _)  = I (ICastHoleGround (λ _ _ ()) x GSumHole)
  ... | CIFHAp (_ , _ , _ , refl , _ )             = I (ICastHoleGround (λ _ _ ()) x GSumHole)
  ... | CIFHCase (_ , _ , _ , _ , _ , _ , _ , refl , _ ) = I (ICastHoleGround (λ _ _ ()) x GSumHole)
  ... | CIFHFst (_ , _ , refl , _ , _ , _ , _) = I (ICastHoleGround (λ _ _ ()) x GSumHole)
  ... | CIFHSnd (_ , _ , refl , _ , _ , _ , _) = I (ICastHoleGround (λ _ _ ()) x GSumHole)
  ... | CIFHCast (_ , _ , refl , _ , GNum , _)     = S (_ , Step FHOuter (ITCastFail GNum GSumHole (λ ())) FHOuter)
  ... | CIFHCast (_ , _ , refl , _ , GArrHole , _) = S (_ , Step FHOuter (ITCastFail GArrHole GSumHole (λ ())) FHOuter)
  ... | CIFHCast (_ , _ , refl , _ , GSumHole , _) = S (_ , Step FHOuter (ITCastSucceed GSumHole) FHOuter)
  ... | CIFHCast (_ , _ , refl , _ , GProdHole , _) = S (_ , Step FHOuter (ITCastFail GProdHole GSumHole λ ()) FHOuter)
  progress (TACast wt (TCHole2 {τ11 ⊠ τ12})) | I x
    with ground-decidable (τ11 ⊠ τ12)
  ... | Inr y = S (_ , Step FHOuter (ITExpand (MGProd (π2 (π2 (ground-not-holes y))))) FHOuter)
  ... | Inl GProdHole
    with canonical-indeterminate-forms-hole wt x
  ... | CIFHEHole (_ , _ , _ , refl , _)           = I (ICastHoleGround (λ _ _ ()) x GProdHole)
  ... | CIFHNEHole (_ , _ , _ , _ , _ , refl , _)  = I (ICastHoleGround (λ _ _ ()) x GProdHole)
  ... | CIFHAp (_ , _ , _ , refl , _ )             = I (ICastHoleGround (λ _ _ ()) x GProdHole)
  ... | CIFHCase (_ , _ , _ , _ , _ , _ , _ , refl , _ ) = I (ICastHoleGround (λ _ _ ()) x GProdHole)
  ... | CIFHFst (_ , _ , refl , _ , _ , _ , _) = I (ICastHoleGround (λ _ _ ()) x GProdHole)
  ... | CIFHSnd (_ , _ , refl , _ , _ , _ , _) = I (ICastHoleGround (λ _ _ ()) x GProdHole)
  ... | CIFHCast (_ , _ , refl , _ , GNum , _)     = S (_ , Step FHOuter (ITCastFail GNum GProdHole (λ ())) FHOuter)
  ... | CIFHCast (_ , _ , refl , _ , GArrHole , _) = S (_ , Step FHOuter (ITCastFail GArrHole GProdHole (λ ())) FHOuter)
  ... | CIFHCast (_ , _ , refl , _ , GSumHole , _) = S (_ , Step FHOuter (ITCastFail GSumHole GProdHole λ ()) FHOuter)
  ... | CIFHCast (_ , _ , refl , _ , GProdHole , _) = S (_ , Step FHOuter (ITCastSucceed GProdHole) FHOuter)

    -- if both are arrows
  progress (TACast wt (TCArr {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | I x
    with htype-dec (τ1 ==> τ2)  (τ1' ==> τ2')
  ... | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  ... | Inr y    = I (ICastArr y x)

    -- if both are sums
  progress (TACast wt (TCSum {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | I x
    with htype-dec (τ1 ⊕ τ2) (τ1' ⊕ τ2')
  ... | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  ... | Inr y    = I (ICastSum y x)
  progress (TACast wt (TCProd {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | I x
    with htype-dec (τ1 ⊠ τ2) (τ1' ⊠ τ2')
  ... | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  ... | Inr y    = I (ICastProd y x)
    -- boxed value cases, inspect how the casts are related by consistency
    -- step by ID if the casts are the same
  progress (TACast wt TCRefl) | BV x = S (_ , Step FHOuter ITCastID FHOuter)
    -- if left is hole
  progress (TACast wt (TCHole1 {τ = τ})) | BV x
    with τ | ground-decidable τ
  ... | τ | Inl g = BV (BVHoleCast g x)
  ... | num | Inr y = abort (y GNum)
  ... | ⦇-⦈ | Inr y = S (_ , Step FHOuter ITCastID FHOuter)
  ... | τ1 ==> τ2 | Inr y
    with (htype-dec (τ1 ==> τ2) (⦇-⦈ ==> ⦇-⦈))
  ... | Inl refl = BV (BVHoleCast GArrHole x)
  ... | Inr y    = S (_ , Step FHOuter (ITGround (MGArr y)) FHOuter)
  progress (TACast wt (TCHole1 {τ = τ})) | BV x  | τ1 ⊕ τ2 | Inr y
    with (htype-dec (τ1 ⊕ τ2) (⦇-⦈ ⊕ ⦇-⦈))
  ... | Inl refl = BV (BVHoleCast GSumHole x)
  ... | Inr y    = S (_ , Step FHOuter (ITGround (MGSum y)) FHOuter)
  progress (TACast wt (TCHole1 {τ = τ})) | BV x  | τ1 ⊠ τ2 | Inr y
    with (htype-dec (τ1 ⊠ τ2) (⦇-⦈ ⊠ ⦇-⦈))
  ... | Inl refl = BV (BVHoleCast GProdHole x)
  ... | Inr y = S (_ , Step FHOuter (ITGround (MGProd y)) FHOuter)
    -- if right is hole
  progress {τ = τ} (TACast wt TCHole2) | BV x
    with canonical-boxed-forms-hole wt x
  ... | d' , τ' , refl , gnd , wt'
    with htype-dec τ τ'
  ... | Inl refl = S (_  , Step FHOuter (ITCastSucceed gnd) FHOuter)
  ... | Inr x₁
    with ground-decidable τ
  ... | Inl y = S (_ , Step FHOuter (ITCastFail gnd y (flip x₁)) FHOuter)
  ... | Inr y
    with not-ground y
  ... | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  ... | Inr (Inl (τ1 , τ2 , refl)) = S (_ , Step FHOuter (ITExpand (MGArr (π1 (ground-not-holes y)))) FHOuter)
  ... | Inr (Inr (Inl (τ1 , τ2 , refl))) =  S (_ , Step FHOuter (ITExpand (MGSum (π1 (π2 (ground-not-holes y))))) FHOuter)
  ... | Inr (Inr (Inr (τ1 , τ2 , refl))) = S (_ , Step FHOuter (ITExpand (MGProd (π2 (π2 (ground-not-holes y))))) FHOuter)
    -- if both arrows
  progress (TACast wt (TCArr {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | BV x
    with htype-dec (τ1 ==> τ2) (τ1' ==> τ2')
  ... | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  ... | Inr y = BV (BVArrCast y x)
    -- if both sums
  progress (TACast wt (TCSum {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | BV x
    with htype-dec (τ1 ⊕ τ2) (τ1' ⊕ τ2')
  ... | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  ... | Inr y = BV (BVSumCast y x)
  progress (TACast wt (TCProd {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | BV x
    with htype-dec (τ1 ⊠ τ2) (τ1' ⊠ τ2')
  ... | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  ... | Inr y = BV (BVProdCast y x)
   -- failed casts
  progress (TAFailedCast wt y z w)
    with progress wt
  ... | S (d' , Step x a q) = S (_ , Step (FHFailedCast x) a (FHFailedCast q))
  ... | I x = I (IFailedCast (FIndet x) y z w)
  ... | BV x = I (IFailedCast (FBoxedVal x) y z w)


{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module Verification.CorruptFormalisations where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.Loop
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------

-- Corrupt as a constant.
module Constant where
  postulate
    corrupt   : D
    corrupt-T : ∀ os x xs →
                corrupt · (T ∷ os) · (x ∷ xs) ≡ ok x ∷ corrupt · os · xs
    corrupt-F : ∀ os x xs →
                corrupt · (F ∷ os) · (x ∷ xs) ≡ error ∷ corrupt · os · xs

-- Corrupt as a binary function.
module BinaryFunction where
  postulate
    corrupt   : D → D → D
    corrupt-T : ∀ os x xs →
                corrupt (T ∷ os) (x ∷ xs) ≡ ok x ∷ corrupt os xs
    corrupt-F : ∀ os x xs →
                corrupt (F ∷ os) (x ∷ xs) ≡ error ∷ corrupt os xs


{-# OPTIONS --rewriting #-}

data _==_ {A : Set} (a : A) : A → Set where
  idp : a == a
{-# BUILTIN REWRITE _==_ #-}

ap : {A B : Set} (f : A → B) {x y : A}
  → x == y → f x == f y
ap f idp = idp

postulate
  Circle : Set
  base : Circle
  loop : base == base

module _ (A : Set) (base* : A) (loop* : base* == base*) where
  postulate
    Circle-rec : Circle → A
    Circle-base-β : Circle-rec base == base*
  {-# REWRITE Circle-base-β #-}
  postulate
    Circle-loop-β : ap Circle-rec loop == loop*
  {-# REWRITE Circle-loop-β #-}

test : (x : Circle) → ap (Circle-rec (Circle → Circle) (λ y → y) idp x) loop == idp
test x = idp

{-
An internal error has occurred. Please report this as a bug.
Location of the error: src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs:178
-}


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

-- Some of the obvious properties of cartesian functors
module Categories.Functor.Cartesian.Properties where

open import Level
open import Data.Product using (Σ ; _,_)

open import Categories.Category
open import Categories.Category.Cartesian.Structure
open import Categories.Functor using (Functor; _∘F_) renaming (id to idF)
open import Categories.Functor.Properties
open import Categories.Functor.Cartesian
open import Categories.Functor.Monoidal
open import Categories.NaturalTransformation

import Categories.Morphism as M
import Categories.Morphism.Reasoning as MR
import Categories.Object.Terminal as ⊤
import Categories.Object.Product as P

private
  variable
    o ℓ e o′ ℓ′ e′ o″ ℓ″ e″ : Level

module _ (C : CartesianCategory o ℓ e) where
  open CartesianCategory C
  open P U

  idF-IsCartesianF : IsCartesianF C C idF
  idF-IsCartesianF = record
    { F-resp-⊤ = terminal.⊤-is-terminal
    ; F-resp-× = Product⇒IsProduct product
    }

  idF-CartesianF : CartesianF C C
  idF-CartesianF = record
    { isCartesian = idF-IsCartesianF
    }

module _ (A : CartesianCategory o ℓ e) (B : CartesianCategory o′ ℓ′ e′) (C : CartesianCategory o″ ℓ″ e″) where
  private
    module A = CartesianCategory A
    module B = CartesianCategory B
    module C = CartesianCategory C
    open P C.U

  ∘-IsCartesianF : ∀ {F : Functor A.U B.U} {G : Functor B.U C.U} →
                    IsCartesianF B C G → IsCartesianF A B F →
                    IsCartesianF A C (G ∘F F)
  ∘-IsCartesianF {F} {G} CG CF = record
    { F-resp-⊤ = ⊤.Terminal.⊤-is-terminal (⊤.transport-by-iso C.U C.terminal
                                          (M.≅.trans C.U (M.≅.sym C.U CG.⊤-iso) ([ G ]-resp-≅ (M.≅.sym B.U CF.⊤-iso))))
    ; F-resp-× = record
      { ⟨_,_⟩    = λ f g → G.₁ (CF.×-iso.to _ _) C.∘ CG.×-iso.to _ _ C.∘ C.⟨ f , g ⟩
      ; project₁ = λ {_ f g} → begin
        G.₁ (F.₁ A.π₁) C.∘ G.₁ (CF.×-iso.to _ _) C.∘ CG.×-iso.to _ _ C.∘ C.⟨ f , g ⟩ ≈⟨ refl⟩∘⟨ refl⟩∘⟨ ([ CG.F-prod _ _ ]⟨⟩∘ ○ CG.F-prod.⟨⟩-cong₂ _ _ C.project₁ C.project₂) ⟩
        G.₁ (F.₁ A.π₁) C.∘ G.₁ (CF.×-iso.to _ _) C.∘ CG.F-resp-×.⟨ f , g ⟩           ≈⟨ pullˡ ([ G ]-resp-∘ CF.F-resp-×.project₁) ⟩
        G.₁ B.π₁ C.∘ CG.F-resp-×.⟨ f , g ⟩                                           ≈⟨ CG.F-resp-×.project₁ ⟩
        f ∎
      ; project₂ = λ {_ f g} → begin
        G.₁ (F.₁ A.π₂) C.∘ G.₁ (CF.×-iso.to _ _) C.∘ CG.×-iso.to _ _ C.∘ C.⟨ f , g ⟩ ≈⟨ refl⟩∘⟨ refl⟩∘⟨ ([ CG.F-prod _ _ ]⟨⟩∘ ○ CG.F-prod.⟨⟩-cong₂ _ _ C.project₁ C.project₂) ⟩
        G.₁ (F.₁ A.π₂) C.∘ G.₁ (CF.×-iso.to _ _) C.∘ CG.F-resp-×.⟨ f , g ⟩           ≈⟨ pullˡ ([ G ]-resp-∘ CF.F-resp-×.project₂) ⟩
        G.₁ B.π₂ C.∘ CG.F-resp-×.⟨ f , g ⟩                                           ≈⟨ CG.F-resp-×.project₂ ⟩
        g ∎
      ; unique   = λ {_ h f g} eq₁ eq₂ → begin
        G.₁ (CF.×-iso.to _ _) C.∘ CG.×-iso.to _ _ C.∘ C.⟨ f , g ⟩
          ≈⟨ refl⟩∘⟨ refl⟩∘⟨ C.unique′ (C.project₁ ○ ⟺ eq₁ ○ pushˡ (⟺ ([ G ]-resp-∘ B.project₁)) ○ pushˡ (⟺ C.project₁))
                                       (C.project₂ ○ ⟺ eq₂ ○ pushˡ (⟺ ([ G ]-resp-∘ B.project₂)) ○ pushˡ (⟺ C.project₂)) ⟩
        G.₁ (CF.×-iso.to _ _) C.∘ CG.×-iso.to _ _ C.∘ CG.×-iso.from _ _ C.∘ G.₁ (CF.×-iso.from _ _) C.∘ h
          ≈⟨ refl⟩∘⟨ cancelˡ (CG.×-iso.isoˡ _ _) ⟩
        G.₁ (CF.×-iso.to _ _) C.∘ G.₁ (CF.×-iso.from _ _) C.∘ h
          ≈⟨ cancelˡ (M._≅_.isoˡ ([ G ]-resp-≅ (CF.×-iso _ _))) ⟩
        h
          ∎
      }
    }
    where module F  = Functor F
          module G  = Functor G
          module CG = IsCartesianF CG
          module CF = IsCartesianF CF
          open C.HomReasoning
          open MR C.U

∘-CartesianF : {A : CartesianCategory o ℓ e} {B : CartesianCategory o′ ℓ′ e′} {C : CartesianCategory o″ ℓ″ e″} →
               CartesianF B C → CartesianF A B → CartesianF A C
∘-CartesianF G F = record { isCartesian = ∘-IsCartesianF _ _ _ (CartesianF.isCartesian G) (CartesianF.isCartesian F) }

module _ {C : CartesianCategory o ℓ e} {D : CartesianCategory o′ ℓ′ e′} where
  private
    module C = CartesianCategory C
    module D = CartesianCategory D
    open D.HomReasoning
    open MR D.U
    open M D.U

  isMonoidalFunctor : CartesianF C D → MonoidalFunctor C.monoidalCategory D.monoidalCategory
  isMonoidalFunctor F = record
    { F          = F.F
    ; isMonoidal = record
      { ε             = F.⊤-iso.to
      ; ⊗-homo        = ntHelper record
        { η       = λ { (X , Y) → F.×-iso.to X Y }
        ; commute = λ { {X , Y} {Z , W} (f , g) →
          F.F-prod.unique′ _ _
            (begin
              F.₁ C.π₁ D.∘ F.×-iso.to Z W D.∘ (F.₁ f D.⁂ F.₁ g) ≈⟨ pullˡ F.F-resp-×.project₁ ⟩
              D.π₁ D.∘ (F.₁ f D.⁂ F.₁ g)                        ≈⟨ D.project₁ ⟩
              F.₁ f D.∘ D.π₁                                    ≈˘⟨ pullʳ F.F-resp-×.project₁ ⟩
              (F.₁ f D.∘ F.₁ C.π₁) D.∘ F.×-iso.to X Y           ≈˘⟨ pullˡ ([ F.F ]-resp-square C.project₁) ⟩
              F.₁ C.π₁ D.∘ F.₁ (f C.⁂ g) D.∘ F.×-iso.to X Y     ∎)
            (begin
              F.₁ C.π₂ D.∘ F.×-iso.to Z W D.∘ (F.₁ f D.⁂ F.₁ g) ≈⟨ pullˡ F.F-resp-×.project₂ ⟩
              D.π₂ D.∘ (F.₁ f D.⁂ F.₁ g)                        ≈⟨ D.project₂ ⟩
              F.₁ g D.∘ D.π₂                                    ≈˘⟨ pullʳ F.F-resp-×.project₂ ⟩
              (F.₁ g D.∘ F.₁ C.π₂) D.∘ F.×-iso.to X Y           ≈˘⟨ pullˡ ([ F.F ]-resp-square C.project₂) ⟩
              F.₁ C.π₂ D.∘ F.₁ (f C.⁂ g) D.∘ F.×-iso.to X Y     ∎)
          }
        }
      ; associativity = λ {X Y Z} → let open P D.U in begin
        F.₁ C.associator.from D.∘ F.×-iso.to (X C.× Y) Z D.∘ (F.×-iso.to X Y D.⁂ D.id)
          ≈⟨ F.F-resp-⟨⟩′ _ _ ⟩∘⟨ [ D.product ⇒ D.product ⇒ F.F-prod _ _ ]repack∘× ⟩
        F.F-resp-×.⟨ F.₁ (C.π₁ C.∘ C.π₁) , F.₁ C.⟨ C.π₂ C.∘ C.π₁ , C.π₂ ⟩ ⟩ D.∘ F.F-resp-×.⟨ F.×-iso.to X Y D.∘ D.π₁ , D.id D.∘ D.π₂ ⟩
          ≈⟨ F.F-prod.⟨⟩-cong₂ _ _ F.homomorphism (F.F-resp-⟨⟩′ _ _ ○ F.F-prod.⟨⟩-cong₂ _ _ F.homomorphism D.Equiv.refl) ⟩∘⟨refl ⟩
        F.F-resp-×.⟨ F.₁ C.π₁ D.∘ F.₁ C.π₁ , F.F-resp-×.⟨ F.₁ C.π₂ D.∘ F.₁ C.π₁ , F.₁ C.π₂ ⟩ ⟩ D.∘ F.F-resp-×.⟨ F.×-iso.to X Y D.∘ D.π₁ , D.id D.∘ D.π₂ ⟩
          ≈⟨ [ F.F-prod _ _ ]⟨⟩∘ ⟩
        F.F-resp-×.⟨ (F.₁ C.π₁ D.∘ F.₁ C.π₁) D.∘ _ , F.F-resp-×.⟨ F.₁ C.π₂ D.∘ F.₁ C.π₁ , F.₁ C.π₂ ⟩ D.∘ _ ⟩
          ≈⟨ F.F-prod.⟨⟩-cong₂ _ _ (pullʳ F.F-resp-×.project₁ ○ pullˡ F.F-resp-×.project₁)
                                   [ F.F-prod _ _ ]⟨⟩∘ ⟩
        F.F-resp-×.⟨ D.π₁ D.∘ D.π₁ , F.F-resp-×.⟨ (F.₁ C.π₂ D.∘ F.₁ C.π₁) D.∘ _ , F.₁ C.π₂ D.∘ _ ⟩ ⟩
          ≈⟨ F.F-prod.⟨⟩-cong₂ _ _ D.Equiv.refl
            (F.F-prod.⟨⟩-cong₂ _ _ (pullʳ F.F-resp-×.project₁ ○ pullˡ F.F-resp-×.project₂)
                                   (F.F-resp-×.project₂ ○ D.identityˡ)) ⟩
        F.F-resp-×.⟨ D.π₁ D.∘ D.π₁ , F.F-resp-×.⟨ D.π₂ D.∘ D.π₁ , D.π₂ ⟩ ⟩
          ≈˘⟨ F.F-prod.⟨⟩-cong₂ _ _ D.identityˡ ([ F.F-prod _ _ ]⟨⟩∘ ○ (F.F-prod.⟨⟩-cong₂ _ _ D.project₁ D.project₂)) ⟩
        F.F-resp-×.⟨ D.id D.∘ D.π₁ D.∘ D.π₁ , F.×-iso.to Y Z D.∘ D.⟨ D.π₂ D.∘ D.π₁ , D.π₂ ⟩ ⟩
          ≈˘⟨ [ D.product ⇒ (F.F-prod _ _) ]×∘⟨⟩ ⟩
        F.F-resp-×.⟨ D.id D.∘ D.π₁ , F.×-iso.to Y Z D.∘ D.π₂ ⟩ D.∘ D.associator.from
          ≈˘⟨ pullˡ [ D.product ⇒ D.product ⇒ F.F-prod _ _ ]repack∘× ⟩
        F.×-iso.to X (Y C.× Z) D.∘ (D.id D.⁂ F.×-iso.to Y Z) D.∘ D.associator.from
          ∎
      ; unitaryˡ      = begin
        F.₁ C.π₂ D.∘ F.F-resp-×.⟨ D.π₁ , D.π₂ ⟩ D.∘ (F.F-resp-⊤.! D.⁂ D.id) ≈⟨ pullˡ F.F-resp-×.project₂ ⟩
        D.π₂ D.∘ (F.F-resp-⊤.! D.⁂ D.id)                                    ≈⟨ D.project₂ ⟩
        D.id D.∘ D.π₂                                                       ≈⟨ D.identityˡ ⟩
        D.π₂                                                                ∎
      ; unitaryʳ      = begin
        F.₁ C.π₁ D.∘ F.F-resp-×.⟨ D.π₁ , D.π₂ ⟩ D.∘ (D.id D.⁂ F.F-resp-⊤.!) ≈⟨ pullˡ F.F-resp-×.project₁ ⟩
        D.π₁ D.∘ (D.id D.⁂ F.F-resp-⊤.!)                                    ≈⟨ D.project₁ ⟩
        D.id D.∘ D.π₁                                                       ≈⟨ D.identityˡ ⟩
        D.π₁                                                                ∎
      }
    }
    where module F = CartesianF F

  isStrongMonoidalFunctor : CartesianF C D → StrongMonoidalFunctor C.monoidalCategory D.monoidalCategory
  isStrongMonoidalFunctor F = record
    { F                = F.F
    ; isStrongMonoidal = record
      { ε             = ≅.sym F.⊤-iso
      ; ⊗-homo        = record
        { F⇒G = MF.⊗-homo
        ; F⇐G = ntHelper record
          { η       = λ { (X , Y) → F.×-iso.from X Y }
          ; commute = λ { {X , Y} {Z , W} (f , g) →
            begin
              D.⟨ F.₁ C.π₁ , F.₁ C.π₂ ⟩ D.∘ F.₁ (f C.⁂ g)                   ≈⟨ D.⟨⟩∘ ⟩
              D.⟨ F.₁ C.π₁ D.∘ F.₁ (f C.⁂ g) , F.₁ C.π₂ D.∘ F.₁ (f C.⁂ g) ⟩ ≈⟨ D.⟨⟩-cong₂ ([ F.F ]-resp-square C.project₁) ([ F.F ]-resp-square C.project₂) ⟩
              D.⟨ F.₁ f D.∘ F.F₁ C.π₁ , F.₁ g D.∘ F.F₁ C.π₂ ⟩               ≈˘⟨ D.⁂∘⟨⟩ ⟩
              (F.₁ f D.⁂ F.₁ g) D.∘ D.⟨ F.F₁ C.π₁ , F.F₁ C.π₂ ⟩             ∎ }
          }
        ; iso = λ { (X , Y) → record
          { isoˡ = F.×-iso.isoʳ X Y
          ; isoʳ = F.×-iso.isoˡ X Y
          } }
        }
      ; associativity = MF.associativity
      ; unitaryˡ      = MF.unitaryˡ
      ; unitaryʳ      = MF.unitaryʳ
      }
    }
    where module F  = CartesianF F
          module MF = MonoidalFunctor (isMonoidalFunctor F)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Type(s) used (only) when calling out to Haskell via the FFI
------------------------------------------------------------------------

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

module Foreign.Haskell where

open import Level

-- A unit type.

data Unit : Set where
  unit : Unit

{-# COMPILE GHC Unit = data () (()) #-}
{-# COMPILE UHC Unit = data __UNIT__ (__UNIT__) #-}

-- A pair type

record Pair {ℓ ℓ′ : Level} (A : Set ℓ) (B : Set ℓ′) : Set (ℓ ⊔ ℓ′) where
  constructor _,_
  field  fst : A
         snd : B
open Pair public

{-# FOREIGN GHC type AgdaPair l1 l2 a b = (a , b) #-}
{-# COMPILE GHC Pair = data MAlonzo.Code.Foreign.Haskell.AgdaPair ((,)) #-}


------------------------------------------------------------------------
-- The lens type in Lens.Non-dependent.Higher.Capriotti.Variant, but
-- with erased "proofs"
------------------------------------------------------------------------

{-# OPTIONS --cubical #-}

import Equality.Path as P

module Lens.Non-dependent.Higher.Capriotti.Variant.Erased
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

open import Logical-equivalence using (_⇔_)
open import Prelude

open import Bijection equality-with-J using (_↔_)
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq using (_≃_)
open import Equivalence.Erased.Cubical eq as EEq using (_≃ᴱ_)
open import Equivalence.Erased.Contractible-preimages.Cubical eq as ECP
  using (_⁻¹ᴱ_)
open import Erased.Cubical eq
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional eq as T using (∥_∥; ∣_∣)
open import Preimage equality-with-J using (_⁻¹_)
open import Univalence-axiom equality-with-J

open import Lens.Non-dependent eq
import Lens.Non-dependent.Higher.Erased eq as Higher
import Lens.Non-dependent.Higher.Capriotti.Variant eq as V

private
  variable
    a b p : Level
    A B   : Type a

------------------------------------------------------------------------
-- The lens type family

-- Coherently constant type-valued functions.

Coherently-constant :
  {A : Type a} → (A → Type p) → Type (a ⊔ lsuc p)
Coherently-constant {p = p} {A = A} P =
  ∃ λ (Q : ∥ A ∥ → Type p) → ∀ x → P x ≃ᴱ Q ∣ x ∣

-- Higher lenses with erased "proofs".

Lens : Type a → Type b → Type (lsuc (a ⊔ b))
Lens A B = ∃ λ (get : A → B) → Coherently-constant (get ⁻¹ᴱ_)

-- In erased contexts Lens A B is equivalent to V.Lens A B.

@0 Lens≃Variant-lens : Lens A B ≃ V.Lens A B
Lens≃Variant-lens =
  (∃ λ get → ∃ λ Q → ∀ x → get ⁻¹ᴱ x ≃ᴱ Q ∣ x ∣)  ↝⟨ (∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ → inverse
                                                      EEq.≃≃≃ᴱ) ⟩
  (∃ λ get → ∃ λ Q → ∀ x → get ⁻¹ᴱ x ≃  Q ∣ x ∣)  ↝⟨ (∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ →
                                                      Eq.≃-preserves ext (inverse ECP.⁻¹≃⁻¹ᴱ) F.id) ⟩□
  (∃ λ get → ∃ λ Q → ∀ x → get ⁻¹  x ≃  Q ∣ x ∣)  □

-- Some derived definitions.

module Lens {A : Type a} {B : Type b} (l : Lens A B) where

  -- A getter.

  get : A → B
  get = proj₁ l

  -- A predicate.

  H : Pow a ∥ B ∥
  H = proj₁ (proj₂ l)

  -- An equivalence (with erased proofs).

  get⁻¹ᴱ-≃ᴱ : ∀ b → get ⁻¹ᴱ b ≃ᴱ H ∣ b ∣
  get⁻¹ᴱ-≃ᴱ = proj₂ (proj₂ l)

  -- All the getter's "preimages" are equivalent (with erased proofs).

  get⁻¹ᴱ-constant : (b₁ b₂ : B) → get ⁻¹ᴱ b₁ ≃ᴱ get ⁻¹ᴱ b₂
  get⁻¹ᴱ-constant b₁ b₂ =
    get ⁻¹ᴱ b₁  ↝⟨ get⁻¹ᴱ-≃ᴱ b₁ ⟩
    H ∣ b₁ ∣    ↔⟨ ≡⇒≃ $ cong H $ T.truncation-is-proposition _ _ ⟩
    H ∣ b₂ ∣    ↝⟨ inverse $ get⁻¹ᴱ-≃ᴱ b₂ ⟩□
    get ⁻¹ᴱ b₂  □

  -- The two directions of get⁻¹ᴱ-constant.

  get⁻¹ᴱ-const : (b₁ b₂ : B) → get ⁻¹ᴱ b₁ → get ⁻¹ᴱ b₂
  get⁻¹ᴱ-const b₁ b₂ = _≃ᴱ_.to (get⁻¹ᴱ-constant b₁ b₂)

  get⁻¹ᴱ-const⁻¹ᴱ : (b₁ b₂ : B) → get ⁻¹ᴱ b₂ → get ⁻¹ᴱ b₁
  get⁻¹ᴱ-const⁻¹ᴱ b₁ b₂ = _≃ᴱ_.from (get⁻¹ᴱ-constant b₁ b₂)

  -- Some coherence properties.

  @0 get⁻¹ᴱ-const-∘ :
    (b₁ b₂ b₃ : B) (p : get ⁻¹ᴱ b₁) →
    get⁻¹ᴱ-const b₂ b₃ (get⁻¹ᴱ-const b₁ b₂ p) ≡ get⁻¹ᴱ-const b₁ b₃ p
  get⁻¹ᴱ-const-∘ b₁ b₂ b₃ p =
    _≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ b₃)
      (≡⇒→ (cong H $ T.truncation-is-proposition _ _)
         (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b₂)
            (_≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ b₂)
               (≡⇒→ (cong H $ T.truncation-is-proposition _ _)
                  (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b₁) p)))))                ≡⟨ cong (_≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ _) ∘ ≡⇒→ _) $
                                                                   _≃ᴱ_.right-inverse-of (get⁻¹ᴱ-≃ᴱ _) _ ⟩
    _≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ b₃)
      (≡⇒→ (cong H $ T.truncation-is-proposition _ _)
         (≡⇒→ (cong H $ T.truncation-is-proposition _ _)
            (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b₁) p)))                        ≡⟨ cong (λ eq → _≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ _) (_≃_.to eq (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ _) _))) $ sym $
                                                                   ≡⇒≃-trans ext _ _ ⟩
    _≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ b₃)
      (≡⇒→ (trans (cong H $ T.truncation-is-proposition _ _)
              (cong H $ T.truncation-is-proposition _ _))
            (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b₁) p))                         ≡⟨ cong (λ eq → _≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ b₃) (≡⇒→ eq _)) $
                                                                   trans (sym $ cong-trans _ _ _) $
                                                                   cong (cong H) $ mono₁ 1 T.truncation-is-proposition _ _ ⟩∎
    _≃ᴱ_.from (get⁻¹ᴱ-≃ᴱ b₃)
      (≡⇒→ (cong H $ T.truncation-is-proposition _ _)
         (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b₁) p))                            ∎

  @0 get⁻¹ᴱ-const-id :
    (b : B) (p : get ⁻¹ᴱ b) → get⁻¹ᴱ-const b b p ≡ p
  get⁻¹ᴱ-const-id b p =
    get⁻¹ᴱ-const b b p                                           ≡⟨ sym $ _≃ᴱ_.left-inverse-of (get⁻¹ᴱ-constant _ _) _ ⟩
    get⁻¹ᴱ-const⁻¹ᴱ b b (get⁻¹ᴱ-const b b (get⁻¹ᴱ-const b b p))  ≡⟨ cong (get⁻¹ᴱ-const⁻¹ᴱ b b) $ get⁻¹ᴱ-const-∘ _ _ _ _ ⟩
    get⁻¹ᴱ-const⁻¹ᴱ b b (get⁻¹ᴱ-const b b p)                     ≡⟨ _≃ᴱ_.left-inverse-of (get⁻¹ᴱ-constant _ _) _ ⟩∎
    p                                                            ∎

  @0 get⁻¹ᴱ-const-inverse :
    (b₁ b₂ : B) (p : get ⁻¹ᴱ b₁) →
    get⁻¹ᴱ-const b₁ b₂ p ≡ get⁻¹ᴱ-const⁻¹ᴱ b₂ b₁ p
  get⁻¹ᴱ-const-inverse b₁ b₂ p =
    sym $ _≃_.to-from (EEq.≃ᴱ→≃ (get⁻¹ᴱ-constant _ _)) (
      get⁻¹ᴱ-const b₂ b₁ (get⁻¹ᴱ-const b₁ b₂ p)  ≡⟨ get⁻¹ᴱ-const-∘ _ _ _ _ ⟩
      get⁻¹ᴱ-const b₁ b₁ p                       ≡⟨ get⁻¹ᴱ-const-id _ _ ⟩∎
      p                                          ∎)

  -- A setter.

  set : A → B → A
  set a b =                      $⟨ get⁻¹ᴱ-const _ _ ⟩
    (get ⁻¹ᴱ get a → get ⁻¹ᴱ b)  ↝⟨ _$ (a , [ refl _ ]) ⟩
    get ⁻¹ᴱ b                    ↝⟨ proj₁ ⟩□
    A                            □

  -- Lens laws.

  @0 get-set : ∀ a b → get (set a b) ≡ b
  get-set a b =
    get (proj₁ (get⁻¹ᴱ-const (get a) b (a , [ refl _ ])))  ≡⟨ erased (proj₂ (get⁻¹ᴱ-const (get a) b (a , [ refl _ ]))) ⟩∎
    b                                                      ∎

  @0 set-get : ∀ a → set a (get a) ≡ a
  set-get a =
    proj₁ (get⁻¹ᴱ-const (get a) (get a) (a , [ refl _ ]))  ≡⟨ cong proj₁ $ get⁻¹ᴱ-const-id _ _ ⟩∎
    a                                                      ∎

  @0 set-set : ∀ a b₁ b₂ → set (set a b₁) b₂ ≡ set a b₂
  set-set a b₁ b₂ =
    proj₁ (get⁻¹ᴱ-const (get (set a b₁)) b₂ (set a b₁ , [ refl _ ]))  ≡⟨ elim¹
                                                                           (λ {b} eq →
                                                                              proj₁ (get⁻¹ᴱ-const (get (set a b₁)) b₂ (set a b₁ , [ refl _ ])) ≡
                                                                              proj₁ (get⁻¹ᴱ-const b b₂ (set a b₁ , [ eq ])))
                                                                           (refl _)
                                                                           (get-set a b₁) ⟩
    proj₁ (get⁻¹ᴱ-const b₁ b₂ (set a b₁ , [ get-set a b₁ ]))          ≡⟨⟩

    proj₁ (get⁻¹ᴱ-const b₁ b₂
             (get⁻¹ᴱ-const (get a) b₁ (a , [ refl _ ])))              ≡⟨ cong proj₁ $ get⁻¹ᴱ-const-∘ _ _ _ _ ⟩∎

    proj₁ (get⁻¹ᴱ-const (get a) b₂ (a , [ refl _ ]))                  ∎

  -- TODO: Can get-set-get and get-set-set be proved for the lens laws
  -- given above?

instance

  -- The lenses defined above have getters and setters.

  has-getter-and-setter :
    Has-getter-and-setter (Lens {a = a} {b = b})
  has-getter-and-setter = record
    { get = Lens.get
    ; set = Lens.set
    }

------------------------------------------------------------------------
-- Equality characterisation lemmas

-- An equality characterisation lemma.

@0 equality-characterisation₁ :
  {A : Type a} {B : Type b} {l₁ l₂ : Lens A B} →
  Block "equality-characterisation" →
  let open Lens in

  (l₁ ≡ l₂)
    ≃
  (∃ λ (g : get l₁ ≡ get l₂) →
   ∃ λ (h : H l₁ ≡ H l₂) →
     ∀ b p →
     subst (_$ ∣ b ∣) h
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym g) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)
equality-characterisation₁ {a = a} {l₁ = l₁} {l₂ = l₂} ⊠ =
  l₁ ≡ l₂                                                           ↝⟨ inverse $ Eq.≃-≡ Lens≃Variant-lens ⟩

  l₁′ ≡ l₂′                                                         ↝⟨ V.equality-characterisation₁ ⊠ ⟩

  (∃ λ (g : get l₁ ≡ get l₂) →
   ∃ λ (h : H l₁ ≡ H l₂) →
     ∀ b p →
     subst (_$ ∣ b ∣) h
       (_≃_.to (V.Lens.get⁻¹-≃ l₁′ b) (subst (_⁻¹ b) (sym g) p)) ≡
     _≃_.to (V.Lens.get⁻¹-≃ l₂′ b) p)                               ↝⟨ (∃-cong λ g → ∃-cong λ h → ∀-cong ext λ b →
                                                                        Π-cong ext ECP.⁻¹≃⁻¹ᴱ λ p →
                                                                        ≡⇒↝ _ $ cong (λ p′ → subst (_$ _) h (_≃_.to (V.Lens.get⁻¹-≃ l₁′ _) p′) ≡
                                                                                _≃_.to (V.Lens.get⁻¹-≃ l₂′ _) p)
                                                                          (
     subst (_⁻¹ b) (sym g) p                                               ≡⟨ elim₁
                                                                                (λ g → subst (_⁻¹ b) (sym g) p ≡
                                                                                Σ-map id erased (subst (_⁻¹ᴱ b) (sym g) (Σ-map id [_]→ p)))
                                                                                (
       subst (_⁻¹ b) (sym (refl _)) p                                            ≡⟨ trans (cong (flip (subst (_⁻¹ b)) _) sym-refl) $
                                                                                subst-refl _ _ ⟩

       p                                                                         ≡⟨ cong (Σ-map id erased) $ sym $
                                                                                trans (cong (flip (subst (_⁻¹ᴱ b)) _) sym-refl) $
                                                                                subst-refl _ _ ⟩∎
       Σ-map id erased
         (subst (_⁻¹ᴱ b) (sym (refl _)) (Σ-map id [_]→ p))                       ∎)
                                                                                _ ⟩
     Σ-map id erased (subst (_⁻¹ᴱ b) (sym g) (Σ-map id [_]→ p))            ≡⟨⟩

     _≃_.from ECP.⁻¹≃⁻¹ᴱ
       (subst (_⁻¹ᴱ b) (sym g) (_≃_.to ECP.⁻¹≃⁻¹ᴱ p))                      ∎)) ⟩□

  (∃ λ (g : get l₁ ≡ get l₂) →
   ∃ λ (h : H l₁ ≡ H l₂) →
     ∀ b p →
     subst (_$ ∣ b ∣) h
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym g) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                    □
  where
  open Lens

  l₁′ = _≃_.to Lens≃Variant-lens l₁
  l₂′ = _≃_.to Lens≃Variant-lens l₂

-- Another equality characterisation lemma.

@0 equality-characterisation₂ :
  {l₁ l₂ : Lens A B} →
  Block "equality-characterisation" →
  let open Lens in

  (l₁ ≡ l₂)
    ≃
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≡ H l₂ b) →
     ∀ b p →
     subst id (h ∣ b ∣)
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ g)) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)
equality-characterisation₂ {l₁ = l₁} {l₂ = l₂} ⊠ =
  l₁ ≡ l₂                                                               ↝⟨ equality-characterisation₁ ⊠ ⟩

  (∃ λ (g : get l₁ ≡ get l₂) →
   ∃ λ (h : H l₁ ≡ H l₂) →
     ∀ b p →
     subst (_$ ∣ b ∣) h
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym g) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                        ↝⟨ (Σ-cong-contra (Eq.extensionality-isomorphism bad-ext) λ _ →
                                                                            Σ-cong-contra (Eq.extensionality-isomorphism bad-ext) λ _ →
                                                                            F.id) ⟩
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≡ H l₂ b) →
     ∀ b p →
     subst (_$ ∣ b ∣) (⟨ext⟩ h)
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ g)) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                        ↝⟨ (∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                            ≡⇒↝ _ $ cong (_≡ _) $
                                                                            subst-ext _ _) ⟩□
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≡ H l₂ b) →
     ∀ b p →
     subst id (h ∣ b ∣)
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ g)) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                        □
  where
  open Lens

-- Yet another equality characterisation lemma.

@0 equality-characterisation₃ :
  {A : Type a} {B : Type b}
  {l₁ l₂ : Lens A B} →
  Block "equality-characterisation" →
  Univalence (a ⊔ b) →
  let open Lens in

  (l₁ ≡ l₂)
    ≃
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≃ H l₂ b) →
     ∀ b p →
     _≃_.to (h ∣ b ∣)
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ g)) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)
equality-characterisation₃ {l₁ = l₁} {l₂ = l₂} ⊠ univ =
  l₁ ≡ l₂                                                               ↝⟨ equality-characterisation₂ ⊠ ⟩

  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≡ H l₂ b) →
     ∀ b p →
     subst id (h ∣ b ∣)
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ g)) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                        ↝⟨ (∃-cong λ _ →
                                                                            Σ-cong-contra (∀-cong ext λ _ → inverse $ ≡≃≃ univ) λ _ → F.id) ⟩
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≃ H l₂ b) →
     ∀ b p →
     subst id (≃⇒≡ univ (h ∣ b ∣))
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ g)) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                        ↝⟨ (∃-cong λ _ → ∃-cong λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                            ≡⇒↝ _ $ cong (_≡ _) $
                                                                            trans (subst-id-in-terms-of-≡⇒↝ equivalence) $
                                                                            cong (λ eq → _≃_.to eq _) $
                                                                            _≃_.right-inverse-of (≡≃≃ univ) _) ⟩□
  (∃ λ (g : ∀ a → get l₁ a ≡ get l₂ a) →
   ∃ λ (h : ∀ b → H l₁ b ≃ H l₂ b) →
     ∀ b p →
     _≃_.to (h ∣ b ∣)
       (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₁ b) (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ g)) p)) ≡
     _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ l₂ b) p)                                        □
  where
  open Lens

------------------------------------------------------------------------
-- Conversion functions

-- The lenses defined above can be converted to and from the lenses
-- defined in Higher.

Lens⇔Higher-lens :
  Block "conversion" →
  Lens A B ⇔ Higher.Lens A B
Lens⇔Higher-lens {A = A} {B = B} ⊠ = record
  { to = λ (g , H , eq) → record
           { R = Σ ∥ B ∥ H

           ; equiv =
               A                                               ↝⟨ (inverse $ drop-⊤-right λ _ → _⇔_.to EEq.Contractibleᴱ⇔≃ᴱ⊤
                                                                   Contractibleᴱ-Erased-other-singleton) ⟩
               (∃ λ (a : A) → ∃ λ (b : B) → Erased (g a ≡ b))  ↔⟨ ∃-comm ⟩
               (∃ λ (b : B) → g ⁻¹ᴱ b)                         ↝⟨ ∃-cong eq ⟩
               (∃ λ (b : B) → H ∣ b ∣)                         ↔⟨ (Σ-cong (inverse T.∥∥×≃) λ _ → ≡⇒≃ $ cong H $ T.truncation-is-proposition _ _) ⟩
               (∃ λ ((b , _) : ∥ B ∥ × B) → H b)               ↔⟨ Σ-assoc F.∘
                                                                  (∃-cong λ _ → ×-comm) F.∘
                                                                  inverse Σ-assoc ⟩□
               Σ ∥ B ∥ H × B                                   □

           ; inhabited = proj₁
           }
  ; from = λ l →
               Higher.Lens.get l
             , (λ _ → Higher.Lens.R l)
             , (λ b → inverse (Higher.remainder≃ᴱget⁻¹ᴱ l b))
  }

-- The conversion preserves getters and setters.

Lens⇔Higher-lens-preserves-getters-and-setters :
  (bl : Block "conversion") →
  Preserves-getters-and-setters-⇔ A B (Lens⇔Higher-lens bl)
Lens⇔Higher-lens-preserves-getters-and-setters bl@⊠ =
    (λ l@(g , H , eq) →
         refl _
       , ⟨ext⟩ λ a → ⟨ext⟩ λ b →
         let h₁ = _≃ᴱ_.to (eq (g a)) (a , [ refl _ ])

             h₂ =
               _≃_.from (≡⇒≃ (cong H _))
                 (subst (H ∘ proj₁) (sym (_≃_.left-inverse-of T.∥∥×≃ _))
                    (≡⇒→ (cong H _) h₁))

             h₃ = ≡⇒→ (cong H _) h₁

             lemma =
               h₂                                                         ≡⟨ sym $ subst-in-terms-of-inverse∘≡⇒↝ equivalence _ _ _ ⟩

               subst H _
                 (subst (H ∘ proj₁) (sym (_≃_.left-inverse-of T.∥∥×≃ _))
                    (≡⇒→ (cong H _) h₁))                                  ≡⟨ cong (λ x → subst H (sym $ T.truncation-is-proposition _ _)
                                                                                (subst (H ∘ proj₁)
                                                                                (sym (_≃_.left-inverse-of T.∥∥×≃ (∣ g a ∣ , b)))
                                                                                x)) $ sym $
                                                                             subst-in-terms-of-≡⇒↝ equivalence _ _ _ ⟩
               subst H _
                 (subst (H ∘ proj₁) (sym (_≃_.left-inverse-of T.∥∥×≃ _))
                    (subst H _ h₁))                                       ≡⟨ cong (λ x → subst H (sym $ T.truncation-is-proposition _ _) x) $
                                                                             subst-∘ _ _ _ ⟩

               subst H _ (subst H _ (subst H _ h₁))                       ≡⟨ cong (λ x → subst H (sym $ T.truncation-is-proposition _ _) x) $
                                                                             subst-subst _ _ _ _ ⟩

               subst H _ (subst H _ h₁)                                   ≡⟨ subst-subst _ _ _ _ ⟩

               subst H _ h₁                                               ≡⟨ cong (λ eq → subst H eq h₁) $
                                                                             mono₁ 1 T.truncation-is-proposition _ _ ⟩

               subst H _ h₁                                               ≡⟨ subst-in-terms-of-≡⇒↝ equivalence _ _ _ ⟩∎

               ≡⇒→ (cong H _) h₁                                          ∎
         in
         proj₁ (_≃ᴱ_.from (eq b) h₂)  ≡⟨ cong (λ h → proj₁ (_≃ᴱ_.from (eq b) h)) lemma ⟩∎
         proj₁ (_≃ᴱ_.from (eq b) h₃)  ∎)
  , (λ l →
         refl _
       , ⟨ext⟩ λ a → ⟨ext⟩ λ b →
         Lens.set (_⇔_.from (Lens⇔Higher-lens bl) l) a b   ≡⟨⟩

         _≃ᴱ_.from (Higher.Lens.equiv l)
           ( ≡⇒→ (cong (λ _ → Higher.Lens.R l) _)
               (Higher.Lens.remainder l a)
           , b
           )                                               ≡⟨ cong (λ eq → _≃ᴱ_.from (Higher.Lens.equiv l) (≡⇒→ eq _ , b)) $
                                                              cong-const _ ⟩
         _≃ᴱ_.from (Higher.Lens.equiv l)
           (≡⇒→ (refl _) (Higher.Lens.remainder l a) , b)  ≡⟨ cong (λ f → _≃ᴱ_.from (Higher.Lens.equiv l) (f _ , b)) $
                                                              ≡⇒→-refl ⟩
         _≃ᴱ_.from (Higher.Lens.equiv l)
           (Higher.Lens.remainder l a , b)                 ≡⟨⟩

         Higher.Lens.set l a b                             ∎)

-- Lens A B is equivalent to Higher.Lens A B (with erased proofs,
-- assuming univalence).

Lens≃ᴱHigher-lens :
  {A : Type a} {B : Type b} →
  Block "conversion" →
  @0 Univalence (a ⊔ b) →
  Lens A B ≃ᴱ Higher.Lens A B
Lens≃ᴱHigher-lens {A = A} {B = B} bl univ =
  EEq.↔→≃ᴱ
    (_⇔_.to (Lens⇔Higher-lens bl))
    (_⇔_.from (Lens⇔Higher-lens bl))
    (to∘from bl)
    (from∘to bl)
  where
  @0 to∘from :
    (bl : Block "conversion") →
    ∀ l →
    _⇔_.to (Lens⇔Higher-lens bl) (_⇔_.from (Lens⇔Higher-lens bl) l) ≡ l
  to∘from ⊠ l = _↔_.from (Higher.equality-characterisation₂ univ)
    ( (∥ B ∥ × R  ↔⟨ (drop-⊤-left-× λ r → _⇔_.to contractible⇔↔⊤ $
                      propositional⇒inhabited⇒contractible
                        T.truncation-is-proposition
                        (inhabited r)) ⟩□
       R          □)
    , (λ a →
         ≡⇒→ (cong (λ _ → R) (T.truncation-is-proposition _ _))
           (remainder a)                                         ≡⟨ cong (λ eq → ≡⇒→ eq _) $ cong-const _ ⟩

         ≡⇒→ (refl _) (remainder a)                              ≡⟨ cong (_$ _) ≡⇒→-refl ⟩∎

         remainder a                                             ∎)
    , (λ _ → refl _)
    )
    where
    open Higher.Lens l

  @0 from∘to :
    (bl : Block "conversion") →
    ∀ l →
    _⇔_.from (Lens⇔Higher-lens bl) (_⇔_.to (Lens⇔Higher-lens bl) l) ≡ l
  from∘to bl@⊠ l = _≃_.from (equality-characterisation₃ ⊠ univ)
    ( (λ _ → refl _)
    , Σ∥B∥H≃H
    , (λ b p@(a , [ get-a≡b ]) →
         _≃_.to (Σ∥B∥H≃H ∣ b ∣)
           (_≃ᴱ_.from (Higher.remainder≃ᴱget⁻¹ᴱ
                         (_⇔_.to (Lens⇔Higher-lens bl) l) b)
              (subst (_⁻¹ᴱ b) (sym (⟨ext⟩ λ _ → refl _)) p))       ≡⟨ cong (_≃_.to (Σ∥B∥H≃H ∣ b ∣) ∘
                                                                            _≃ᴱ_.from (Higher.remainder≃ᴱget⁻¹ᴱ
                                                                                (_⇔_.to (Lens⇔Higher-lens bl) l) b)) $
                                                                      trans (cong (flip (subst (_⁻¹ᴱ b)) p) $
                                                                             trans (cong sym ext-refl) $
                                                                             sym-refl) $
                                                                      subst-refl _ _ ⟩
         _≃_.to (Σ∥B∥H≃H ∣ b ∣)
           (_≃ᴱ_.from (Higher.remainder≃ᴱget⁻¹ᴱ
                         (_⇔_.to (Lens⇔Higher-lens bl) l) b)
              p)                                                   ≡⟨⟩

         _≃_.to (Σ∥B∥H≃H ∣ b ∣)
           (Higher.Lens.remainder
              (_⇔_.to (Lens⇔Higher-lens bl) l) a)                  ≡⟨⟩

         subst H _
           (≡⇒→ (cong H _) (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ (get a))
                              (a , [ refl _ ])))                   ≡⟨ cong (subst H _) $ sym $
                                                                      subst-in-terms-of-≡⇒↝ equivalence _ _ _ ⟩

         subst H _ (subst H _ (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ (get a))
                                 (a , [ refl _ ])))                ≡⟨ subst-subst _ _ _ _ ⟩

         subst H _ (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ (get a)) (a , [ refl _ ]))  ≡⟨ cong (λ eq → subst H eq (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ (get a)) (a , [ refl _ ]))) $
                                                                      mono₁ 1 T.truncation-is-proposition _ _ ⟩
         subst H (cong ∣_∣ get-a≡b)
           (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ (get a)) (a , [ refl _ ]))          ≡⟨ elim¹
                                                                        (λ {b} eq →
                                                                           subst H (cong ∣_∣ eq)
                                                                             (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ (get a)) (a , [ refl _ ])) ≡
                                                                           _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b) (a , [ eq ]))
                                                                        (
           subst H (cong ∣_∣ (refl _))
             (_≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ (get a)) (a , [ refl _ ]))              ≡⟨ trans (cong (flip (subst H) _) $ cong-refl _) $
                                                                            subst-refl _ _ ⟩
           _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ (get a)) (a , [ refl _ ])                  ∎)
                                                                        _ ⟩∎
         _≃ᴱ_.to (get⁻¹ᴱ-≃ᴱ b) p                                   ∎)
    )
    where
    open Lens l

    Σ∥B∥H≃H = λ b →
      Σ ∥ B ∥ H  ↔⟨ (drop-⊤-left-Σ $ _⇔_.to contractible⇔↔⊤ $
                     propositional⇒inhabited⇒contractible
                       T.truncation-is-proposition b) ⟩□
      H b        □

-- The equivalence preserves getters and setters.

Lens≃ᴱHigher-lens-preserves-getters-and-setters :
  {A : Type a} {B : Type b}
  (bl : Block "conversion")
  (@0 univ : Univalence (a ⊔ b)) →
  Preserves-getters-and-setters-⇔ A B
    (_≃ᴱ_.logical-equivalence (Lens≃ᴱHigher-lens bl univ))
Lens≃ᴱHigher-lens-preserves-getters-and-setters bl univ =
  Lens⇔Higher-lens-preserves-getters-and-setters bl


module getline where

-- https://github.com/alhassy/AgdaCheatSheet#interacting-with-the-real-world-compilation-haskell-and-io

open import Data.Nat                 using (ℕ; suc)
open import Data.Nat.Show            using (show)
open import Data.Char                using (Char)
open import Data.List                as L using (map; sum; upTo)
open import Function                 using (_$_; const; _∘_)
open import Data.String              as S using (String; _++_; fromList)
open import Agda.Builtin.Unit        using (⊤)
open import Codata.Musical.Colist    using (take)
open import Codata.Musical.Costring  using (Costring)
open import Data.Vec.Bounded         as B using (toList)
open import Agda.Builtin.Coinduction using (♯_)
open import IO                       as IO using (run ; putStrLn ; IO)
import      IO.Primitive             as Primitive

infixr 1 _>>=_ _>>_

_>>=_ : ∀ {ℓ} {α β : Set ℓ} → IO α → (α → IO β) → IO β
this >>= f = ♯ this IO.>>= λ x → ♯ f x

_>>_ : ∀{ℓ} {α β : Set ℓ} → IO α → IO β → IO β
x >> y = x >>= const y

postulate
  getLine∞ : Primitive.IO Costring

{-# FOREIGN GHC
  toColist :: [a] -> MAlonzo.Code.Codata.Musical.Colist.AgdaColist a
  toColist []       = MAlonzo.Code.Codata.Musical.Colist.Nil
  toColist (x : xs) =
    MAlonzo.Code.Codata.Musical.Colist.Cons x (MAlonzo.RTE.Sharp (toColist xs))
#-}

{- Haskell's prelude is implicitly available; this is for demonstration. -}
{-# FOREIGN GHC import Prelude as Haskell #-}
{-# COMPILE GHC getLine∞  = fmap toColist Haskell.getLine #-}

-- (1)
-- getLine : IO Costring
-- getLine = IO.lift getLine∞

getLine : IO String
getLine = IO.lift
  $ getLine∞ Primitive.>>= (Primitive.return ∘ S.fromList ∘ B.toList ∘ take 100)

postulate readInt  : L.List Char → ℕ
{-# COMPILE GHC readInt = \x -> read x :: Integer  #-}

main : Primitive.IO ⊤
main = run do
  putStrLn "Hello, world! I'm a compiled Agda program!"

  IO.putStrLn "What is your name?:"
  name ← getLine

  IO.putStrLn "Please enter a number:"
  num ← getLine

  let tri = show $ sum $ upTo $ suc $ readInt $ S.toList num
  putStrLn $ "The triangle number of " ++ num ++ " is " ++ tri

  putStrLn ("Bye, " ++ name)
  -- IO.putStrLn∞ ("Bye, " ++ name)  {- If using approach (1) above. -}


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- The syntax of terms (Fig. 1a and 1b).
------------------------------------------------------------------------

-- The syntax of terms depends on the syntax of simple types
-- (because terms are indexed by types in order to rule out
-- ill-typed terms). But we are in the Parametric.* hierarchy, so
-- we don't know the full syntax of types, only how to lift the
-- syntax of base types into the syntax of simple types. This
-- means that we have to be parametric in the syntax of base
-- types, too.
--
-- In such parametric modules that depend on other parametric
-- modules, we first import our dependencies under a more
-- convenient name.

import Parametric.Syntax.Type as Type

-- Then we start the module proper, with parameters for all
-- extension points of our dependencies. Note that here, the
-- "Structure" naming convenion makes some sense, because we can
-- say that we need some "Type.Structure" in order to define the
-- "Term.Structure".

module Parametric.Syntax.Term
    (Base : Type.Structure)
  where

-- Now inside the module, we can open our dependencies with the
-- parameters for their extension points. Again, here the name
-- "Structure" makes some sense, because we can say that we want
-- to access the "Type.Structure" that is induced by Base.

open Type.Structure Base

-- At this point, we have dealt with the extension points of our
-- dependencies, and we have all the definitions about simple
-- types, contexts, variables, and variable sets in scope that we
-- provided in Parametric.Syntax.Type. Now we can proceed to
-- define our own extension point, following the pattern
-- explained in Parametric.Syntax.Type.

open import Relation.Binary.PropositionalEquality hiding ([_])
open import Function using (_∘_)
open import Data.Unit
open import Data.Sum

-- Our extension point is a set of primitives, indexed by the
-- types of their arguments and their return type. In general, if
-- you're confused about what an extension point means, you might
-- want to open the corresponding module in the Nehemiah
-- hierarchy to see how it is implemented in the example
-- plugin. In this case, that would be the Nehemiah.Syntax.Term
-- module.

Structure : Set₁
Structure = Type → Set

module Structure (Const : Structure) where

  -- Declarations of Term and Terms to enable mutual recursion.
  --
  -- Note that terms are indexed by contexts and types. In the
  -- paper, we define the abstract syntax of terms in Fig 1a and
  -- then define a type system in Fig 1b. All lemmas and theorems
  -- then explicitly specify that they only hold for well-typed
  -- terms. Here, we use the indices to define a type that can
  -- only hold well-typed terms in the first place.
  data Term
    (Γ : Context) :
    (τ : Type) → Set

  open import Base.Data.DependentList public

  -- (Terms Γ Σ) represents a list of terms with types from Σ
  -- with free variables bound in Γ.
  Terms : Context → Context → Set
  Terms Γ = DependentList (Term Γ)

  -- (Term Γ τ) represents a term of type τ
  -- with free variables bound in Γ.
  data Term Γ where
    -- constants aka. primitives
    const : ∀ {τ} →
      (c : Const τ) →
      Term Γ τ
    var : ∀ {τ} →
      (x : Var Γ τ) →
      Term Γ τ
    app : ∀ {σ τ}
      (s : Term Γ (σ ⇒ τ)) →
      (t : Term Γ σ) →
      Term Γ τ
    -- we use de Bruijn indices, so we don't need binding occurrences.
    abs : ∀ {σ τ}
      (t : Term (σ • Γ) τ) →
      Term Γ (σ ⇒ τ)

  -- Free variables
  FV : ∀ {τ Γ} → Term Γ τ → Vars Γ

  FV (const ι) = none
  FV (var x) = singleton x
  FV (abs t) = tail (FV t)
  FV (app s t) = FV s ∪ FV t

  closed? : ∀ {τ Γ} → (t : Term Γ τ) → (FV t ≡ none) ⊎ ⊤
  closed? t = empty? (FV t)

  -- Weakening

  weaken : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Term Γ₁ τ →
    Term Γ₂ τ
  weaken Γ₁≼Γ₂ (const c) = const c
  weaken Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
  weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
  weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

  -- Specialized weakening
  weaken₁ : ∀ {Γ σ τ} →
    Term Γ τ → Term (σ • Γ) τ
  weaken₁ t = weaken (drop _ • ≼-refl) t

  weaken₂ : ∀ {Γ α β τ} →
    Term Γ τ → Term (α • β • Γ) τ
  weaken₂ t = weaken (drop _ • drop _ • ≼-refl) t

  weaken₃ : ∀ {Γ α β γ τ} →
    Term Γ τ → Term (α • β • γ • Γ) τ
  weaken₃ t = weaken (drop _ • drop _ • drop _ • ≼-refl) t

  -- Shorthands for nested applications
  app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
  app₂ f x = app (app f x)

  app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
  app₃ f x = app₂ (app f x)

  app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
  app₄ f x = app₃ (app f x)

  app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
  app₅ f x = app₄ (app f x)

  app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
  app₆ f x = app₅ (app f x)

  -- HOAS-like smart constructors for lambdas, for different arities.

  -- We could also write this:
  module NamespaceForBadAbs₁ where
    abs₁′ :
      ∀ {Γ τ₁ τ} →
        (Term (τ₁ • Γ) τ₁ → Term (τ₁ • Γ) τ) →
        (Term Γ (τ₁ ⇒ τ))
    abs₁′ {Γ} {τ₁} = λ f → abs (f (var this))

  -- However, this is less general, and it is harder to reuse. In particular,
  -- this cannot be used inside abs₂, ..., abs₆.

  -- Now, let's write other variants with a loop!
  open import Data.Vec using (_∷_; []; Vec; foldr; [_]; reverse)
  open import Data.Nat
  module AbsNHelpers where
    open import Function
    hoasArgType : ∀ {n} → Context → Type → Vec Type n → Set
    hoasArgType Γ τres = foldr _ (λ a b → a → b) (Term Γ τres) ∘ Data.Vec.map (Term Γ)
    -- That is,
    --hoasArgType Γ τres [] = Term Γ τres
    --hoasArgType Γ τres (τ₀ ∷ τs) = Term Γ τ₀ → hoasArgType Γ τres τs

    hoasResType : ∀ {n} → Type → Vec Type n → Type
    hoasResType τres = foldr _ _⇒_ τres

    absNType : {n : ℕ} → Vec _ n → Set
    absNType τs = ∀ {Γ τres} →
      (f : ∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → hoasArgType Γ′ τres τs) →
      Term Γ (hoasResType τres τs)

    drop-≼-l : ∀ {Γ Γ′ τ} → (τ • Γ ≼ Γ′) → Γ ≼ Γ′
    drop-≼-l Γ′≼Γ′₁ = ≼-trans (drop _ • ≼-refl) Γ′≼Γ′₁

    absN : {n : ℕ} → (τs : Vec _ n) → absNType τs
    absN []        f = f {Γ≼Γ′ = ≼-refl}
    absN (τ₁ ∷ τs) f =
      abs (absN τs
        (λ {_} {Γ′≼Γ′₁} →
          f
            {Γ≼Γ′ = drop-≼-l Γ′≼Γ′₁}
            (weaken Γ′≼Γ′₁ (var this))))

    -- Using a similar trick, we can declare absV (where V stands for variadic),
    -- which takes the N implicit type arguments individually, collects them and
    -- passes them on to absN. This is inspired by the example in the Agda 2.4.0
    -- release notes about support for varying arity. To collect them, we need
    -- to use an accumulator argument.

    absVType : ∀ n {m} (τs : Vec Type m) → Set
    absVType zero       τs = absNType (reverse τs)
    absVType (suc n) τs = {τ₁ : Type} → absVType n (τ₁ ∷ τs)

    absVAux : ∀ {m} → (τs : Vec Type m) → ∀ n → absVType n τs
    absVAux τs zero    = absN (reverse τs)
    -- (Support for varying arity does not work here, so {τ₁} must be bound in
    -- the right-hand side).
    absVAux τs (suc n) {τ₁} = absVAux (τ₁ ∷ τs) n --λ {τ₁} → absVAux (τ₁ ∷ τs) n

    -- "Initialize" accumulator to the empty list.
    absV = absVAux []
    -- We could maybe define absV directly, without going through absN, by
    -- making hoasArgType and hoasResType also variadic, but I don't see a clear
    -- advantage.

  open AbsNHelpers using (absV) public

  {-
  Example types:
  absV 1:
    {τ₁ : Type} {Γ : Context} {τres : Type} →
      ({Γ′ : Context} {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τres) →
      Term Γ (τ₁ ⇒ τres)

  absV 2:
    {τ₁ : Type} {τ₁ = τ₂ : Type} {Γ : Context} {τres : Type} →
      ({Γ′ : Context} {Γ≼Γ′ : Γ ≼ Γ′} →
       Term Γ′ τ₁ → Term Γ′ τ₂ → Term Γ′ τres) →
      Term Γ (τ₁ ⇒ τ₂ ⇒ τres)

  -}


------------------------------------------------------------------------
-- Pi with partiality algebra families as codomains
------------------------------------------------------------------------

{-# OPTIONS --erased-cubical --safe #-}

module Partiality-algebra.Pi where

open import Equality.Propositional.Cubical
open import Logical-equivalence using (_⇔_)
open import Prelude hiding (T)

open import H-level equality-with-J
open import H-level.Closure equality-with-J

open import Partiality-algebra as PA hiding (id; _∘_)

open Partiality-algebra-with
open Partiality-algebra

-- Applies an increasing sequence of functions to a value.

at-with :
  ∀ {a b p q} {A : Type a} {T : A → Type p} {B : A → Type b}
  (P : (x : A) → Partiality-algebra-with (T x) q (B x)) →
  let module P x = Partiality-algebra-with (P x) in
  (∃ λ (f : ℕ → (x : A) → T x) →
     ∀ n x → P._⊑_ x (f n x) (f (suc n) x)) →
  (x : A) → ∃ λ (f : ℕ → T x) →
                ∀ n → P._⊑_ x (f n) (f (suc n))
at-with _ s x = Σ-map (λ f n → f n x) (λ f n → f n x) s

-- Applies an increasing sequence of functions to a value.

at :
  ∀ {a b p q} {A : Type a} {B : A → Type b}
  (P : (x : A) → Partiality-algebra p q (B x)) →
  let module P x = Partiality-algebra (P x) in
  (∃ λ (f : ℕ → (x : A) → P.T x) →
     ∀ n x → P._⊑_ x (f n x) (f (suc n) x)) →
  (x : A) → ∃ λ (f : ℕ → P.T x) →
                ∀ n → P._⊑_ x (f n) (f (suc n))
at P = at-with (partiality-algebra-with ∘ P)

-- A kind of dependent function space from types to
-- Partiality-algebra-with families.

Π-with : ∀ {a b p q}
         (A : Type a) {T : A → Type p} {B : A → Type b} →
         ((x : A) → Partiality-algebra-with (T x) q (B x)) →
         Partiality-algebra-with
           ((x : A) → T x) (a ⊔ q) ((x : A) → B x)
_⊑_               (Π-with A P) = λ f g → ∀ x → _⊑_ (P x) (f x) (g x)
never             (Π-with A P) = λ x → never (P x)
now               (Π-with A P) = λ f x → now (P x) (f x)
⨆                 (Π-with A P) = λ s x → ⨆ (P x) (at-with P s x)
antisymmetry      (Π-with A P) = λ p q → ⟨ext⟩ λ x →
                                   antisymmetry (P x) (p x) (q x)
T-is-set-unused   (Π-with A P) = Π-closure ext 2 λ x →
                                   T-is-set-unused (P x)
⊑-refl            (Π-with A P) = λ f x → ⊑-refl (P x) (f x)
⊑-trans           (Π-with A P) = λ f g x → ⊑-trans (P x) (f x) (g x)
never⊑            (Π-with A P) = λ f x → never⊑ (P x) (f x)
upper-bound       (Π-with A P) = λ s n x →
                                   upper-bound (P x) (at-with P s x) n
least-upper-bound (Π-with A P) = λ s ub is-ub x →
                                   least-upper-bound
                                     (P x) (at-with P s x) (ub x)
                                     (λ n → is-ub n x)
⊑-propositional   (Π-with A P) = Π-closure ext 1 λ x →
                                   ⊑-propositional (P x)

-- A kind of dependent function space from types to partiality algebra
-- families.

Π : ∀ {a b p q} →
    (A : Type a) {B : A → Type b} →
    ((x : A) → Partiality-algebra p q (B x)) →
    Partiality-algebra (a ⊔ p) (a ⊔ q) ((x : A) → B x)
T                       (Π A P) = (x : A) → T (P x)
partiality-algebra-with (Π A P) = Π-with A (partiality-algebra-with ∘ P)