quox/lib/Quox/Reduce.idr

module Quox.Reduce

import Quox.No
import Quox.Syntax
import Quox.Definition
import Quox.Displace
import Quox.Typing.Context
import Quox.Typing.Error
import Data.SnocVect
import Data.Maybe
import Data.List
import Control.Eff

%default total


-- [fixme] rename this to Whnf and the interface to CanWhnf
public export
WhnfM : Type -> Type
WhnfM = Eff [NameGen, Except Error]

export
runWhnfWith : NameSuf -> WhnfM a -> (Either Error a, NameSuf)
runWhnfWith suf act = extract $ runStateAt GEN suf $ runExcept act

export
runWhnf : WhnfM a -> Either Error a
runWhnf = fst . runWhnfWith 0


public export
0 RedexTest : TermLike -> Type
RedexTest tm = {d, n : Nat} -> Definitions -> tm d n -> Bool

public export
interface Whnf (0 tm : TermLike) (0 isRedex : RedexTest tm) | tm
where
  whnf : {d, n : Nat} -> (defs : Definitions) ->
         (ctx : WhnfContext d n) ->
         tm d n -> WhnfM (Subset (tm d n) (No . isRedex defs))

public export %inline
whnf0 : {d, n : Nat} -> {0 isRedex : RedexTest tm} -> Whnf tm isRedex =>
        (defs : Definitions) -> WhnfContext d n -> tm d n -> WhnfM (tm d n)
whnf0 defs ctx t = fst <$> whnf defs ctx t

public export
0 IsRedex, NotRedex : {isRedex : RedexTest tm} -> Whnf tm isRedex =>
                      Definitions -> Pred (tm d n)
IsRedex  defs = So . isRedex defs
NotRedex defs = No . isRedex defs

public export
0 NonRedex : (tm : TermLike) -> {isRedex : RedexTest tm} ->
             Whnf tm isRedex => (d, n : Nat) -> (defs : Definitions) -> Type
NonRedex tm d n defs = Subset (tm d n) (NotRedex defs)

public export %inline
nred : {0 isRedex : RedexTest tm} -> (0 _ : Whnf tm isRedex) =>
       (t : tm d n) -> (0 nr : NotRedex defs t) => NonRedex tm d n defs
nred t = Element t nr


public export %inline
isLamHead : Elim {} -> Bool
isLamHead (Ann (Lam {}) (Pi {}) _) = True
isLamHead (Coe {})                 = True
isLamHead _                        = False

public export %inline
isDLamHead : Elim {} -> Bool
isDLamHead (Ann (DLam {}) (Eq {}) _) = True
isDLamHead (Coe {})                  = True
isDLamHead _                         = False

public export %inline
isPairHead : Elim {} -> Bool
isPairHead (Ann (Pair {}) (Sig {}) _) = True
isPairHead (Coe {})                   = True
isPairHead _                          = False

public export %inline
isTagHead : Elim {} -> Bool
isTagHead (Ann (Tag {}) (Enum {}) _) = True
isTagHead (Coe {})                   = True
isTagHead _                          = False

public export %inline
isNatHead : Elim {} -> Bool
isNatHead (Ann (Zero {}) (Nat {}) _) = True
isNatHead (Ann (Succ {}) (Nat {}) _) = True
isNatHead (Coe {})                   = True
isNatHead _                          = False

public export %inline
isBoxHead : Elim {} -> Bool
isBoxHead (Ann (Box {}) (BOX {}) _) = True
isBoxHead (Coe {})                  = True
isBoxHead _                         = False

public export %inline
isE : Term {} -> Bool
isE (E {}) = True
isE _      = False

public export %inline
isAnn : Elim {} -> Bool
isAnn (Ann {}) = True
isAnn _        = False

||| true if a term is syntactically a type.
public export %inline
isTyCon : Term {} -> Bool
isTyCon (TYPE  {}) = True
isTyCon (Pi    {}) = True
isTyCon (Lam   {}) = False
isTyCon (Sig   {}) = True
isTyCon (Pair  {}) = False
isTyCon (Enum  {}) = True
isTyCon (Tag   {}) = False
isTyCon (Eq    {}) = True
isTyCon (DLam  {}) = False
isTyCon (Nat   {}) = True
isTyCon (Zero  {}) = False
isTyCon (Succ  {}) = False
isTyCon (BOX   {}) = True
isTyCon (Box   {}) = False
isTyCon (E     {}) = False
isTyCon (CloT  {}) = False
isTyCon (DCloT {}) = False

||| true if a term is syntactically a type, or a neutral.
public export %inline
isTyConE : Term {} -> Bool
isTyConE s = isTyCon s || isE s

||| true if a term is syntactically a type.
public export %inline
isAnnTyCon : Elim {} -> Bool
isAnnTyCon (Ann ty (TYPE {}) _) = isTyCon ty
isAnnTyCon _                    = False

public export %inline
isK : Dim d -> Bool
isK (K {}) = True
isK _      = False


mutual
  public export
  isRedexE : RedexTest Elim
  isRedexE defs (F {x, _}) {d, n} =
    isJust $ lookupElim x defs {d, n}
  isRedexE _ (B {}) = False
  isRedexE defs (App {fun, _}) =
    isRedexE defs fun || isLamHead fun
  isRedexE defs (CasePair {pair, _}) =
    isRedexE defs pair || isPairHead pair
  isRedexE defs (CaseEnum {tag, _}) =
    isRedexE defs tag || isTagHead tag
  isRedexE defs (CaseNat {nat, _}) =
    isRedexE defs nat || isNatHead nat
  isRedexE defs (CaseBox {box, _}) =
    isRedexE defs box || isBoxHead box
  isRedexE defs (DApp {fun, arg, _}) =
    isRedexE defs fun || isDLamHead fun || isK arg
  isRedexE defs (Ann {tm, ty, _}) =
    isE tm || isRedexT defs tm || isRedexT defs ty
  isRedexE defs (Coe {val, _}) =
    isRedexT defs val || not (isE val)
  isRedexE defs (Comp {ty, r, _}) =
    isRedexT defs ty || isK r
  isRedexE defs (TypeCase {ty, ret, _}) =
    isRedexE defs ty || isRedexT defs ret || isAnnTyCon ty
  isRedexE _ (CloE  {}) = True
  isRedexE _ (DCloE {}) = True

  public export
  isRedexT : RedexTest Term
  isRedexT _    (CloT  {}) = True
  isRedexT _    (DCloT {}) = True
  isRedexT defs (E {e, _}) = isAnn e || isRedexE defs e
  isRedexT _    _          = False


public export
tycaseRhs : (k : TyConKind) -> TypeCaseArms d n ->
            Maybe (ScopeTermN (arity k) d n)
tycaseRhs k arms = lookupPrecise k arms

public export
tycaseRhsDef : Term d n -> (k : TyConKind) -> TypeCaseArms d n ->
               ScopeTermN (arity k) d n
tycaseRhsDef def k arms = fromMaybe (SN def) $ tycaseRhs k arms

public export
tycaseRhs0 : (k : TyConKind) -> TypeCaseArms d n ->
             (0 eq : arity k = 0) => Maybe (Term d n)
tycaseRhs0 k arms {eq} with (tycaseRhs k arms) | (arity k)
  tycaseRhs0 k arms {eq = Refl} | res | 0 = map (.term) res

public export
tycaseRhsDef0 : Term d n -> (k : TyConKind) -> TypeCaseArms d n ->
                (0 eq : arity k = 0) => Term d n
tycaseRhsDef0 def k arms = fromMaybe def $ tycaseRhs0 k arms



private
weakDS : (by : Nat) -> DScopeTerm d n -> DScopeTerm d (by + n)
weakDS by (S names (Y body)) = S names $ Y $ weakT by body
weakDS by (S names (N body)) = S names $ N $ weakT by body

private
dweakS : (by : Nat) -> ScopeTerm d n -> ScopeTerm (by + d) n
dweakS by (S names (Y body)) = S names $ Y $ dweakT by body
dweakS by (S names (N body)) = S names $ N $ dweakT by body

private
coeScoped : {s : Nat} -> DScopeTerm d n -> Dim d -> Dim d -> Loc ->
            ScopeTermN s d n -> ScopeTermN s d n
coeScoped ty p q loc (S names (Y body)) =
  S names $ Y $ E $ Coe (weakDS s ty) p q body loc
coeScoped ty p q loc (S names (N body)) =
  S names $ N $ E $ Coe ty p q body loc


export covering
Whnf Term Reduce.isRedexT

export covering
Whnf Elim Reduce.isRedexE

parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n)
  ||| performs the minimum work required to recompute the type of an elim.
  |||
  ||| ⚠ **assumes the elim is already typechecked.** ⚠
  export covering
  computeElimType : (e : Elim d n) -> (0 ne : No (isRedexE defs e)) =>
                    WhnfM (Term d n)
  computeElimType (F {x, u, loc}) = do
    let Just def = lookup x defs | Nothing => throw $ NotInScope loc x
    pure $ displace u def.type
  computeElimType (B {i, _}) = pure $ ctx.tctx !! i
  computeElimType (App {fun = f, arg = s, loc}) {ne} = do
    Pi {arg, res, _} <- whnf0 defs ctx =<< computeElimType f {ne = noOr1 ne}
      | t => throw $ ExpectedPi loc ctx.names t
    pure $ sub1 res $ Ann s arg loc
  computeElimType (CasePair {pair, ret, _}) = pure $ sub1 ret pair
  computeElimType (CaseEnum {tag, ret, _}) = pure $ sub1 ret tag
  computeElimType (CaseNat {nat, ret, _}) = pure $ sub1 ret nat
  computeElimType (CaseBox {box, ret, _}) = pure $ sub1 ret box
  computeElimType (DApp {fun = f, arg = p, loc}) {ne} = do
    Eq {ty, _} <- whnf0 defs ctx =<< computeElimType f {ne = noOr1 ne}
      | t => throw $ ExpectedEq loc ctx.names t
    pure $ dsub1 ty p
  computeElimType (Ann {ty, _}) = pure ty
  computeElimType (Coe {ty, q, _}) = pure $ dsub1 ty q
  computeElimType (Comp {ty, _}) = pure ty
  computeElimType (TypeCase {ret, _}) = pure ret

parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext (S d) n)
  ||| for π.(x : A) → B, returns (A, B);
  ||| for an elim returns a pair of type-cases that will reduce to that;
  ||| for other intro forms error
  private covering
  tycasePi : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
             WhnfM (Term (S d) n, ScopeTerm (S d) n)
  tycasePi (Pi {arg, res, _}) = pure (arg, res)
  tycasePi (E e) {tnf} = do
    ty <- computeElimType defs ctx e @{noOr2 tnf}
    let loc  = e.loc
        narg = mnb "Arg"; nret = mnb "Ret"
        arg  = E $ typeCase1Y e ty KPi [< !narg, !nret] (BVT 1 loc) loc
        res' = typeCase1Y e (Arr Zero arg ty loc) KPi [< !narg, !nret]
                 (BVT 0 loc) loc
        res  = SY [< !narg] $ E $ App (weakE 1 res') (BVT 0 loc) loc
    pure (arg, res)
  tycasePi t = throw $ ExpectedPi t.loc ctx.names t

  ||| for (x : A) × B, returns (A, B);
  ||| for an elim returns a pair of type-cases that will reduce to that;
  ||| for other intro forms error
  private covering
  tycaseSig : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
              WhnfM (Term (S d) n, ScopeTerm (S d) n)
  tycaseSig (Sig {fst, snd, _}) = pure (fst, snd)
  tycaseSig (E e) {tnf} = do
    ty <- computeElimType defs ctx e @{noOr2 tnf}
    let loc  = e.loc
        nfst = mnb "Fst"; nsnd = mnb "Snd"
        fst  = E $ typeCase1Y e ty KSig [< !nfst, !nsnd] (BVT 1 loc) loc
        snd' = typeCase1Y e (Arr Zero fst ty loc) KSig [< !nfst, !nsnd]
                 (BVT 0 loc) loc
        snd  = SY [< !nfst] $ E $ App (weakE 1 snd') (BVT 0 loc) loc
    pure (fst, snd)
  tycaseSig t = throw $ ExpectedSig t.loc ctx.names t

  ||| for [π. A], returns A;
  ||| for an elim returns a type-case that will reduce to that;
  ||| for other intro forms error
  private covering
  tycaseBOX : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
              WhnfM (Term (S d) n)
  tycaseBOX (BOX {ty, _}) = pure ty
  tycaseBOX (E e) {tnf} = do
    ty <- computeElimType defs ctx e @{noOr2 tnf}
    pure $ E $ typeCase1Y e ty KBOX [< !(mnb "Ty")] (BVT 0 e.loc) e.loc
  tycaseBOX t = throw $ ExpectedBOX t.loc ctx.names t

  ||| for Eq [i ⇒ A] l r, returns (A‹0/i›, A‹1/i›, A, l, r);
  ||| for an elim returns five type-cases that will reduce to that;
  ||| for other intro forms error
  private covering
  tycaseEq : (t : Term (S d) n) -> (0 tnf : No (isRedexT defs t)) =>
             WhnfM (Term (S d) n, Term (S d) n, DScopeTerm (S d) n,
                           Term (S d) n, Term (S d) n)
  tycaseEq (Eq {ty, l, r, _}) = pure (ty.zero, ty.one, ty, l, r)
  tycaseEq (E e) {tnf} = do
    ty <- computeElimType defs ctx e @{noOr2 tnf}
    let loc   = e.loc
        names = traverse' (\x => mnb x) [< "A0", "A1", "A", "L", "R"]
        a0    = E $ typeCase1Y e ty KEq !names (BVT 4 loc) loc
        a1    = E $ typeCase1Y e ty KEq !names (BVT 3 loc) loc
        a'    = typeCase1Y e (Eq0 ty a0 a1 loc) KEq !names (BVT 2 loc) loc
        a     = SY [< !(mnb "i")] $ E $ DApp (dweakE 1 a') (B VZ loc) loc
        l     = E $ typeCase1Y e a0 KEq !names (BVT 1 loc) loc
        r     = E $ typeCase1Y e a1 KEq !names (BVT 0 loc) loc
    pure (a0, a1, a, l, r)
  tycaseEq t = throw $ ExpectedEq t.loc ctx.names t

-- new block because the functions below might pass a different ctx
-- into the ones above
parameters {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n)
  ||| reduce a function application `App (Coe ty p q val) s loc`
  private covering
  piCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) ->
          (val, s : Term d n) -> Loc ->
          WhnfM (Subset (Elim d n) (No . isRedexE defs))
  piCoe sty@(S [< i] ty) p q val s loc = do
    -- (coe [i ⇒ π.(x : A) → B] @p @q t) s ⇝
    -- coe [i ⇒ B[𝒔‹i›/x] @p @q ((t ∷ (π.(x : A) → B)‹p/i›) 𝒔‹p›)
    --   where 𝒔‹j› ≔ coe [i ⇒ A] @q @j s
    --
    -- type-case is used to expose A,B if the type is neutral
    let ctx1 = extendDim i ctx
    Element ty tynf <- whnf defs ctx1 ty.term
    (arg, res) <- tycasePi defs ctx1 ty
    let s0   = CoeT i arg q p s s.loc
        body = E $ App (Ann val (ty // one p) val.loc) (E s0) loc
        s1   = CoeT i (arg // (BV 0 i.loc ::: shift 2)) (weakD 1 q) (BV 0 i.loc)
                    (s // shift 1) s.loc
    whnf defs ctx $ CoeT i (sub1 res s1) p q body loc

  ||| reduce a pair elimination `CasePair pi (Coe ty p q val) ret body loc`
  private covering
  sigCoe : (qty : Qty) ->
           (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
           (ret : ScopeTerm d n) -> (body : ScopeTermN 2 d n) -> Loc ->
           WhnfM (Subset (Elim d n) (No . isRedexE defs))
  sigCoe qty sty@(S [< i] ty) p q val ret body loc = do
    -- caseπ (coe [i ⇒ (x : A) × B] @p @q s) return z ⇒ C of { (a, b) ⇒ e }
    -- ⇝
    -- caseπ s ∷ ((x : A) × B)‹p/i› return z ⇒ C
    -- of { (a, b) ⇒
    --   e[(coe [i ⇒ A] @p @q a)/a,
    --     (coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @p @i a)/x]] @p @q b)/b] }
    --
    -- type-case is used to expose A,B if the type is neutral
    let ctx1 = extendDim i ctx
    Element ty tynf <- whnf defs ctx1 ty.term
    (tfst, tsnd) <- tycaseSig defs ctx1 ty
    let [< x, y] = body.names
        a' = CoeT i (weakT 2 tfst) p q (BVT 1 noLoc) x.loc
        tsnd' = tsnd.term //
          (CoeT i (weakT 2 $ tfst // (B VZ noLoc ::: shift 2))
            (weakD 1 p) (B VZ noLoc) (BVT 1 noLoc) y.loc ::: shift 2)
        b' = CoeT i tsnd' p q (BVT 0 noLoc) y.loc
    whnf defs ctx $ CasePair qty (Ann val (ty // one p) val.loc) ret
      (ST body.names $ body.term // (a' ::: b' ::: shift 2)) loc

  ||| reduce a dimension application `DApp (Coe ty p q val) r loc`
  private covering
  eqCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
          (r : Dim d) -> Loc ->
          WhnfM (Subset (Elim d n) (No . isRedexE defs))
  eqCoe sty@(S [< j] ty) p q val r loc = do
    -- (coe [j ⇒ Eq [i ⇒ A] L R] @p @q eq) @r
    -- ⇝
    -- comp [j ⇒ A‹r/i›] @p @q (eq ∷ (Eq [i ⇒ A] L R)‹p/j›)
    --   @r { 0 j ⇒ L; 1 j ⇒ R }
    let ctx1 = extendDim j ctx
    Element ty tynf <- whnf defs ctx1 ty.term
    (a0, a1, a, s, t) <- tycaseEq defs ctx1 ty
    let a'   = dsub1 a (weakD 1 r)
        val' = E $ DApp (Ann val (ty // one p) val.loc) r loc
    whnf defs ctx $ CompH j a' p q val' r j s j t loc

  ||| reduce a pair elimination `CaseBox pi (Coe ty p q val) ret body`
  private covering
  boxCoe : (qty : Qty) ->
           (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
           (ret : ScopeTerm d n) -> (body : ScopeTerm d n) -> Loc ->
           WhnfM (Subset (Elim d n) (No . isRedexE defs))
  boxCoe qty sty@(S [< i] ty) p q val ret body loc = do
    -- caseπ (coe [i ⇒ [ρ. A]] @p @q s) return z ⇒ C of { [a] ⇒ e }
    -- ⇝
    -- caseπ s ∷ [ρ. A]‹p/i› return z ⇒ C
    -- of { [a] ⇒ e[(coe [i ⇒ A] p q a)/a] }
    let ctx1 = extendDim i ctx
    Element ty tynf <- whnf defs ctx1 ty.term
    ta <- tycaseBOX defs ctx1 ty
    let a' = CoeT i (weakT 1 ta) p q (BVT 0 noLoc) body.name.loc
    whnf defs ctx $ CaseBox qty (Ann val (ty // one p) val.loc) ret
      (ST body.names $ body.term // (a' ::: shift 1)) loc


||| reduce a type-case applied to a type constructor
private covering
reduceTypeCase : {d, n : Nat} -> (defs : Definitions) -> WhnfContext d n ->
                 (ty : Term d n) -> (u : Universe) -> (ret : Term d n) ->
                 (arms : TypeCaseArms d n) -> (def : Term d n) ->
                 (0 _ : So (isTyCon ty)) => Loc ->
                 WhnfM (Subset (Elim d n) (No . isRedexE defs))
reduceTypeCase defs ctx ty u ret arms def loc = case ty of
  -- (type-case ★ᵢ ∷ _ return Q of { ★ ⇒ s; ⋯ }) ⇝ s ∷ Q
  TYPE {} =>
    whnf defs ctx $ Ann (tycaseRhsDef0 def KTYPE arms) ret loc

  -- (type-case π.(x : A) → B ∷ ★ᵢ return Q of { (a → b) ⇒ s; ⋯ }) ⇝
  -- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q
  Pi {arg, res, loc = piLoc, _} =>
    let arg' = Ann arg (TYPE u noLoc) arg.loc
        res' = Ann (Lam res res.loc)
                   (Arr Zero arg (TYPE u noLoc) arg.loc) res.loc
    in
    whnf defs ctx $
      Ann (subN (tycaseRhsDef def KPi arms) [< arg', res']) ret loc

  -- (type-case (x : A) × B ∷ ★ᵢ return Q of { (a × b) ⇒ s; ⋯ }) ⇝
  -- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q
  Sig {fst, snd, loc = sigLoc, _} =>
    let fst' = Ann fst (TYPE u noLoc) fst.loc
        snd' = Ann (Lam snd snd.loc)
                   (Arr Zero fst (TYPE u noLoc) fst.loc) snd.loc
    in
    whnf defs ctx $
      Ann (subN (tycaseRhsDef def KSig arms) [< fst', snd']) ret loc

  -- (type-case {⋯} ∷ _ return Q of { {} ⇒ s; ⋯ }) ⇝ s ∷ Q
  Enum {} =>
    whnf defs ctx $ Ann (tycaseRhsDef0 def KEnum arms) ret loc

  -- (type-case Eq [i ⇒ A] L R ∷ ★ᵢ return Q
  --  of { Eq a₀ a₁ a l r ⇒ s; ⋯ }) ⇝
  -- s[(A‹0/i› ∷ ★ᵢ)/a₀, (A‹1/i› ∷ ★ᵢ)/a₁,
  --   ((δ i ⇒ A) ∷ Eq [★ᵢ] A‹0/i› A‹1/i›)/a,
  --   (L ∷ A‹0/i›)/l, (R ∷ A‹1/i›)/r] ∷ Q
  Eq {ty = a, l, r, loc = eqLoc, _} =>
    let a0 = a.zero; a1 = a.one in
    whnf defs ctx $ Ann
      (subN (tycaseRhsDef def KEq arms)
         [< Ann a0 (TYPE u noLoc) a.loc, Ann a1 (TYPE u noLoc) a.loc,
            Ann (DLam a a.loc) (Eq0 (TYPE u noLoc) a0 a1 a.loc) a.loc,
            Ann l a0 l.loc, Ann r a1 r.loc])
      ret loc

  -- (type-case ℕ ∷ _ return Q of { ℕ ⇒ s; ⋯ }) ⇝ s ∷ Q
  Nat {} =>
    whnf defs ctx $ Ann (tycaseRhsDef0 def KNat arms) ret loc

  -- (type-case [π.A] ∷ ★ᵢ return Q of { [a] ⇒ s; ⋯ }) ⇝ s[(A ∷ ★ᵢ)/a] ∷ Q
  BOX {ty = a, loc = boxLoc, _} =>
    whnf defs ctx $ Ann
      (sub1 (tycaseRhsDef def KBOX arms) (Ann a (TYPE u noLoc) a.loc))
      ret loc


||| pushes a coercion inside a whnf-ed term
private covering
pushCoe : {d, n : Nat} -> (defs : Definitions) -> WhnfContext d n ->
          BindName ->
          (ty : Term (S d) n) -> (0 tynf : No (isRedexT defs ty)) =>
          Dim d -> Dim d ->
          (s : Term d n) -> (0 snf : No (isRedexT defs s)) => Loc ->
          WhnfM (NonRedex Elim d n defs)
pushCoe defs ctx i ty p q s loc =
  if p == q then whnf defs ctx $ Ann s (ty // one q) loc else
  case s of
    -- (coe [_ ⇒ ★ᵢ] @_ @_ ty) ⇝ (ty ∷ ★ᵢ)
    TYPE {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
    Pi   {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
    Sig  {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
    Enum {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
    Eq   {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
    Nat  {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc
    BOX  {} => pure $ nred $ Ann s (TYPE !(unwrapTYPE ty) ty.loc) loc

    -- just η expand it. then whnf for App will handle it later
    -- this is how @xtt does it
    --
    -- (coe [i ⇒ A] @p @q (λ x ⇒ s)) ⇝
    -- (λ y ⇒ (coe [i ⇒ A] @p @q (λ x ⇒ s)) y) ∷ A‹q/i› ⇝ ⋯
    lam@(Lam {body, _}) => do
      let lam'  = CoeT i ty p q lam loc
          term' = LamY !(fresh body.name)
                    (E $ App (weakE 1 lam') (BVT 0 noLoc) loc) loc
          type' = ty // one q
      whnf defs ctx $ Ann term' type' loc

    -- (coe [i ⇒ (x : A) × B] @p @q (s, t)) ⇝
    -- (coe [i ⇒ A] @p @q s,
    --  coe [i ⇒ B[(coe [j ⇒ A‹j/i›] @p @i s)/x]] @p @q t)
    --   ∷ (x : A‹q/i›) × B‹q/i›
    --
    -- can't use η here because... it doesn't exist
    Pair {fst, snd, loc = pairLoc} => do
      let Sig {fst = tfst, snd = tsnd, loc = sigLoc} = ty
        | _ => throw $ ExpectedSig ty.loc (extendDim i ctx.names) ty
      let fst'  = E $ CoeT i tfst p q fst fst.loc
          tfst' = tfst // (B VZ noLoc ::: shift 2)
          tsnd' = sub1 tsnd $
                  CoeT !(fresh i) tfst' (weakD 1 p) (B VZ noLoc)
                    (dweakT 1 fst) fst.loc
          snd'  = E $ CoeT i tsnd' p q snd snd.loc
      pure $
        Element (Ann (Pair fst' snd' pairLoc)
                     (Sig (tfst // one q) (tsnd // one q) sigLoc) loc) Ah

    -- η expand, like for Lam
    --
    -- (coe [i ⇒ A] @p @q (δ j ⇒ s)) ⇝
    -- (δ k ⇒ (coe [i ⇒ A] @p @q (δ j ⇒ s)) @k) ∷ A‹q/i› ⇝ ⋯
    dlam@(DLam {body, _}) => do
      let dlam' = CoeT i ty p q dlam loc
          term' = DLamY !(mnb "j")
                    (E $ DApp (dweakE 1 dlam') (B VZ noLoc) loc) loc
          type' = ty // one q
      whnf defs ctx $ Ann term' type' loc

    -- (coe [_ ⇒ {⋯}] @_ @_ t) ⇝ (t ∷ {⋯})
    Tag {tag, loc = tagLoc} => do
      let Enum {cases, loc = enumLoc} = ty
        | _ => throw $ ExpectedEnum ty.loc (extendDim i ctx.names) ty
      pure $ Element (Ann (Tag tag tagLoc) (Enum cases enumLoc) loc) Ah

    -- (coe [_ ⇒ ℕ] @_ @_ n) ⇝ (n ∷ ℕ)
    Zero {loc = zeroLoc} => do
      pure $ Element (Ann (Zero zeroLoc) (Nat ty.loc) loc) Ah
    Succ {p = pred, loc = succLoc} => do
      pure $ Element (Ann (Succ pred succLoc) (Nat ty.loc) loc) Ah

    -- (coe [i ⇒ [π.A]] @p @q [s]) ⇝
    -- [coe [i ⇒ A] @p @q s] ∷ [π. A‹q/i›]
    Box {val, loc = boxLoc} => do
      let BOX {qty, ty = a, loc = tyLoc} = ty
        | _ => throw $ ExpectedBOX ty.loc (extendDim i ctx.names) ty
      pure $ Element
        (Ann (Box (E $ CoeT i a p q val val.loc) boxLoc)
             (BOX qty (a // one q) tyLoc) loc)
        Ah

    E e => pure $ Element (CoeT i ty p q (E e) e.loc) (snf `orNo` Ah)
where
  unwrapTYPE : Term (S d) n -> WhnfM Universe
  unwrapTYPE (TYPE {l, _}) = pure l
  unwrapTYPE ty = throw $ ExpectedTYPE ty.loc (extendDim i ctx.names) ty


export covering
Whnf Elim Reduce.isRedexE where
  whnf defs ctx (F x u loc) with (lookupElim x defs) proof eq
    _ | Just y  = whnf defs ctx $ setLoc loc $ displace u y
    _ | Nothing = pure $ Element (F x u loc) $ rewrite eq in Ah

  whnf _ _ (B i loc) = pure $ nred $ B i loc

  -- ((λ x ⇒ t) ∷ (π.x : A) → B) s ⇝ t[s∷A/x] ∷ B[s∷A/x]
  whnf defs ctx (App f s appLoc) = do
    Element f fnf <- whnf defs ctx f
    case nchoose $ isLamHead f of
      Left _ => case f of
        Ann (Lam {body, _}) (Pi {arg, res, _}) floc =>
          let s = Ann s arg s.loc in
          whnf defs ctx $ Ann (sub1 body s) (sub1 res s) appLoc
        Coe ty p q val _ => piCoe defs ctx ty p q val s appLoc
      Right nlh => pure $ Element (App f s appLoc) $ fnf `orNo` nlh

  -- case (s, t) ∷ (x : A) × B return p ⇒ C of { (a, b) ⇒ u } ⇝
  -- u[s∷A/a, t∷B[s∷A/x]] ∷ C[(s, t)∷((x : A) × B)/p]
  whnf defs ctx (CasePair pi pair ret body caseLoc) = do
    Element pair pairnf <- whnf defs ctx pair
    case nchoose $ isPairHead pair of
      Left _ => case pair of
        Ann (Pair {fst, snd, _}) (Sig {fst = tfst, snd = tsnd, _}) pairLoc =>
          let fst = Ann fst tfst fst.loc
              snd = Ann snd (sub1 tsnd fst) snd.loc
          in
          whnf defs ctx $ Ann (subN body [< fst, snd]) (sub1 ret pair) caseLoc
        Coe ty p q val _ => do
          sigCoe defs ctx pi ty p q val ret body caseLoc
      Right np =>
        pure $ Element (CasePair pi pair ret body caseLoc) $ pairnf `orNo` np

  -- case 'a ∷ {a,…} return p ⇒ C of { 'a ⇒ u } ⇝
  -- u ∷ C['a∷{a,…}/p]
  whnf defs ctx (CaseEnum pi tag ret arms caseLoc) = do
    Element tag tagnf <- whnf defs ctx tag
    case nchoose $ isTagHead tag of
      Left _ => case tag of
        Ann (Tag t _) (Enum ts _) _ =>
          let ty = sub1 ret tag in
          case lookup t arms of
            Just arm => whnf defs ctx $ Ann arm ty arm.loc
            Nothing  => throw $ MissingEnumArm caseLoc t (keys arms)
        Coe ty p q val _ =>
          -- there is nowhere an equality can be hiding inside an enum type
          whnf defs ctx $
            CaseEnum pi (Ann val (dsub1 ty q) val.loc) ret arms caseLoc
      Right nt =>
        pure $ Element (CaseEnum pi tag ret arms caseLoc) $ tagnf `orNo` nt

  -- case zero ∷ ℕ return p ⇒ C of { zero ⇒ u; … } ⇝
  --   u ∷ C[zero∷ℕ/p]
  --
  -- case succ n ∷ ℕ return p ⇒ C of { succ n', π.ih ⇒ u; … } ⇝
  --   u[n∷ℕ/n', (case n ∷ ℕ ⋯)/ih] ∷ C[succ n ∷ ℕ/p]
  whnf defs ctx (CaseNat pi piIH nat ret zer suc caseLoc) = do
    Element nat natnf <- whnf defs ctx nat
    case nchoose $ isNatHead nat of
      Left _ =>
        let ty = sub1 ret nat in
        case nat of
          Ann (Zero _) (Nat _) _ =>
            whnf defs ctx $ Ann zer ty zer.loc
          Ann (Succ n succLoc) (Nat natLoc) _ =>
            let nn = Ann n (Nat natLoc) succLoc
                tm = subN suc [< nn, CaseNat pi piIH nn ret zer suc caseLoc]
            in
            whnf defs ctx $ Ann tm ty caseLoc
          Coe ty p q val _ =>
            -- same deal as Enum
            whnf defs ctx $
              CaseNat pi piIH (Ann val (dsub1 ty q) val.loc) ret zer suc caseLoc
      Right nn => pure $
        Element (CaseNat pi piIH nat ret zer suc caseLoc) $ natnf `orNo` nn

  -- case [t] ∷ [π.A] return p ⇒ C of { [x] ⇒ u } ⇝
  --   u[t∷A/x] ∷ C[[t] ∷ [π.A]/p]
  whnf defs ctx (CaseBox pi box ret body caseLoc) = do
    Element box boxnf <- whnf defs ctx box
    case nchoose $ isBoxHead box of
      Left _ => case box of
        Ann (Box val boxLoc) (BOX q bty tyLoc) _ =>
          let ty = sub1 ret box in
          whnf defs ctx $ Ann (sub1 body (Ann val bty val.loc)) ty caseLoc
        Coe ty p q val _ =>
          boxCoe defs ctx pi ty p q val ret body caseLoc
      Right nb =>
        pure $ Element (CaseBox pi box ret body caseLoc) $ boxnf `orNo` nb

  -- e : Eq (𝑗 ⇒ A) t u ⊢ e @0 ⇝ t ∷ A‹0/𝑗›
  -- e : Eq (𝑗 ⇒ A) t u ⊢ e @1 ⇝ u ∷ A‹1/𝑗›
  --
  -- ((δ 𝑖 ⇒ s) ∷ Eq (𝑗 ⇒ A) t u) @𝑘 ⇝ s‹𝑘/𝑖› ∷ A‹𝑘/𝑗›
  whnf defs ctx (DApp f p appLoc) = do
    Element f fnf <- whnf defs ctx f
    case nchoose $ isDLamHead f of
      Left _ => case f of
        Ann (DLam {body, _}) (Eq {ty, l, r, _}) _ =>
          whnf defs ctx $
            Ann (endsOr (setLoc appLoc l) (setLoc appLoc r) (dsub1 body p) p)
                (dsub1 ty p) appLoc
        Coe ty p' q' val _ =>
          eqCoe defs ctx ty p' q' val p appLoc
      Right ndlh => case p of
        K e _ => do
          Eq {l, r, ty, _} <- whnf0 defs ctx =<< computeElimType defs ctx f
            | ty => throw $ ExpectedEq ty.loc ctx.names ty
          whnf defs ctx $
            ends (Ann (setLoc appLoc l) ty.zero appLoc)
                 (Ann (setLoc appLoc r) ty.one  appLoc) e
        B {} => pure $ Element (DApp f p appLoc) $ fnf `orNo` ndlh `orNo` Ah

  -- e ∷ A ⇝ e
  whnf defs ctx (Ann s a annLoc) = do
    Element s snf <- whnf defs ctx s
    case nchoose $ isE s of
      Left  _  => let E e = s in pure $ Element e $ noOr2 snf
      Right ne => do
        Element a anf <- whnf defs ctx a
        pure $ Element (Ann s a annLoc) $ ne `orNo` snf `orNo` anf

  whnf defs ctx (Coe (S _ (N ty)) _ _ val coeLoc) =
    whnf defs ctx $ Ann val ty coeLoc
  whnf defs ctx (Coe (S [< i] ty) p q val coeLoc) = do
    Element ty  tynf  <- whnf defs (extendDim i ctx) ty.term
    Element val valnf <- whnf defs ctx val
    pushCoe defs ctx i ty p q val coeLoc

  whnf defs ctx (Comp ty p q val r zero one compLoc) =
    -- comp [A] @p @p s { ⋯ } ⇝ s ∷ A
    if p == q then whnf defs ctx $ Ann val ty compLoc else
    case nchoose (isK r) of
      -- comp [A] @p @q s @0 { 0 j ⇒ t; ⋯ } ⇝ t‹q/j› ∷ A
      -- comp [A] @p @q s @1 { 1 j ⇒ t; ⋯ } ⇝ t‹q/j› ∷ A
      Left y => case r of
        K Zero _ => whnf defs ctx $ Ann (dsub1 zero q) ty compLoc
        K One  _ => whnf defs ctx $ Ann (dsub1 one  q) ty compLoc
      Right nk => do
        Element ty tynf <- whnf defs ctx ty
        pure $ Element (Comp ty p q val r zero one compLoc) $ tynf `orNo` nk

  whnf defs ctx (TypeCase ty ret arms def tcLoc) = do
    Element ty  tynf  <- whnf defs ctx ty
    Element ret retnf <- whnf defs ctx ret
    case nchoose $ isAnnTyCon ty of
      Left  y  =>
        let Ann ty (TYPE u _) _ = ty in
        reduceTypeCase defs ctx ty u ret arms def tcLoc
      Right nt => pure $
        Element (TypeCase ty ret arms def tcLoc) (tynf `orNo` retnf `orNo` nt)

  whnf defs ctx (CloE  (Sub el th)) = whnf defs ctx $ pushSubstsWith' id th el
  whnf defs ctx (DCloE (Sub el th)) = whnf defs ctx $ pushSubstsWith' th id el

export covering
Whnf Term Reduce.isRedexT where
  whnf _ _ t@(TYPE {}) = pure $ nred t
  whnf _ _ t@(Pi   {}) = pure $ nred t
  whnf _ _ t@(Lam  {}) = pure $ nred t
  whnf _ _ t@(Sig  {}) = pure $ nred t
  whnf _ _ t@(Pair {}) = pure $ nred t
  whnf _ _ t@(Enum {}) = pure $ nred t
  whnf _ _ t@(Tag  {}) = pure $ nred t
  whnf _ _ t@(Eq   {}) = pure $ nred t
  whnf _ _ t@(DLam {}) = pure $ nred t
  whnf _ _ t@(Nat  {}) = pure $ nred t
  whnf _ _ t@(Zero {}) = pure $ nred t
  whnf _ _ t@(Succ {}) = pure $ nred t
  whnf _ _ t@(BOX  {}) = pure $ nred t
  whnf _ _ t@(Box  {}) = pure $ nred t

  -- s ∷ A ⇝ s   (in term context)
  whnf defs ctx (E e) = do
    Element e enf <- whnf defs ctx e
    case nchoose $ isAnn e of
      Left  _  => let Ann {tm, _} = e in pure $ Element tm $ noOr1 $ noOr2 enf
      Right na => pure $ Element (E e) $ na `orNo` enf

  whnf defs ctx (CloT  (Sub tm th)) = whnf defs ctx $ pushSubstsWith' id th tm
  whnf defs ctx (DCloT (Sub tm th)) = whnf defs ctx $ pushSubstsWith' th id tm