quox/lib/Quox/Whnf/Main.idr

module Quox.Whnf.Main

import Quox.Whnf.Interface
import Quox.Whnf.ComputeElimType
import Quox.Whnf.TypeCase
import Quox.Whnf.Coercion
import Quox.Displace
import Data.SnocVect

%default total


export covering CanWhnf Term Interface.isRedexT
export covering CanWhnf Elim Interface.isRedexE


covering
CanWhnf Elim Interface.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] (Y ty)) p q val coeLoc) = do
    Element ty  tynf  <- whnf defs (extendDim i ctx) ty
    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

covering
CanWhnf Term Interface.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