quox/lib/Quox/Syntax/Term/Reduce.idr

module Quox.Syntax.Term.Reduce

import Quox.Syntax.Term.Base
import Quox.Syntax.Term.Subst

%default total


mutual
  public export
  data NotCloT : Term {} -> Type where
    NCTYPE : NotCloT $ TYPE _
    NCPi   : NotCloT $ Pi {}
    NCLam  : NotCloT $ Lam {}
    NCEq   : NotCloT $ Eq {}
    NCDLam : NotCloT $ DLam {}
    NCE    : NotCloE e -> NotCloT $ E e

  public export
  data NotCloE : Elim {} -> Type where
    NCF    : NotCloE $ F _
    NCB    : NotCloE $ B _
    NCApp  : NotCloE $ _ :@ _
    NCDApp : NotCloE $ _ :% _
    NCAnn  : NotCloE $ _ :# _

mutual
  export
  notCloT : (t : Term {}) -> Dec (NotCloT t)
  notCloT (TYPE _)  = Yes NCTYPE
  notCloT (Pi {})   = Yes NCPi
  notCloT (Lam {})  = Yes NCLam
  notCloT (Eq {})   = Yes NCEq
  notCloT (DLam {}) = Yes NCDLam
  notCloT (E e) = case notCloE e of
    Yes nc => Yes $ NCE nc
    No  c  => No  $ \case NCE nc => c nc
  notCloT (CloT {})  = No $ \case _ impossible
  notCloT (DCloT {}) = No $ \case _ impossible

  export
  notCloE : (e : Elim {}) -> Dec (NotCloE e)
  notCloE (F _)      = Yes NCF
  notCloE (B _)      = Yes NCB
  notCloE (_ :@ _)   = Yes NCApp
  notCloE (_ :% _)   = Yes NCDApp
  notCloE (_ :# _)   = Yes NCAnn
  notCloE (CloE  {}) = No $ \case _ impossible
  notCloE (DCloE {}) = No $ \case _ impossible

||| a term which is not a top level closure
public export
NonCloTerm : Type -> Nat -> Nat -> Type
NonCloTerm q d n = Subset (Term q d n) NotCloT

||| an elimination which is not a top level closure
public export
NonCloElim : Type -> Nat -> Nat -> Type
NonCloElim q d n = Subset (Elim q d n) NotCloE

public export %inline
ncloT : (t : Term q d n) -> (0 _ : NotCloT t) => NonCloTerm q d n
ncloT t @{p} = Element t p

public export %inline
ncloE : (e : Elim q d n) -> (0 _ : NotCloE e) => NonCloElim q d n
ncloE e @{p} = Element e p



mutual
  ||| if the input term has any top-level closures, push them under one layer of
  ||| syntax
  export %inline
  pushSubstsT : Term q d n -> NonCloTerm q d n
  pushSubstsT s = pushSubstsTWith id id s

  ||| if the input elimination has any top-level closures, push them under one
  ||| layer of syntax
  export %inline
  pushSubstsE : Elim q d n -> NonCloElim q d n
  pushSubstsE e = pushSubstsEWith id id e

  export
  pushSubstsTWith : DSubst dfrom dto -> TSubst q dto from to ->
                    Term q dfrom from -> NonCloTerm q dto to
  pushSubstsTWith th ph (TYPE l) =
    ncloT $ TYPE l
  pushSubstsTWith th ph (Pi qty x a body) =
    ncloT $ Pi qty x (subs a th ph) (subs body th ph)
  pushSubstsTWith th ph (Lam x body) =
    ncloT $ Lam x $ subs body th ph
  pushSubstsTWith th ph (Eq i ty l r) =
    ncloT $ Eq i (subs ty th ph) (subs l th ph) (subs r th ph)
  pushSubstsTWith th ph (DLam i body) =
    ncloT $ DLam i $ subs body th ph
  pushSubstsTWith th ph (E e) =
    let Element e nc = pushSubstsEWith th ph e in ncloT $ E e
  pushSubstsTWith th ph (CloT s ps) =
    pushSubstsTWith th (comp th ps ph) s
  pushSubstsTWith th ph (DCloT s ps) =
    pushSubstsTWith (ps . th) ph s

  export
  pushSubstsEWith : DSubst dfrom dto -> TSubst q dto from to ->
                    Elim q dfrom from -> NonCloElim q dto to
  pushSubstsEWith th ph (F x) =
    ncloE $ F x
  pushSubstsEWith th ph (B i) =
    let res = ph !! i in
    case notCloE res of
         Yes _ => ncloE res
         No  _ => assert_total pushSubstsE res
  pushSubstsEWith th ph (f :@ s) =
    ncloE $ subs f th ph :@ subs s th ph
  pushSubstsEWith th ph (f :% d) =
    ncloE $ subs f th ph :% (d // th)
  pushSubstsEWith th ph (s :# a) =
    ncloE $ subs s th ph :# subs a th ph
  pushSubstsEWith th ph (CloE e ps) =
    pushSubstsEWith th (comp th ps ph) e
  pushSubstsEWith th ph (DCloE e ps) =
    pushSubstsEWith (ps . th) ph e


parameters (th : DSubst dfrom dto) (ph : TSubst q dto from to)
  public export %inline
  pushSubstsTWith' : Term q dfrom from -> Term q dto to
  pushSubstsTWith' s = (pushSubstsTWith th ph s).fst

  public export %inline
  pushSubstsEWith' : Elim q dfrom from -> Elim q dto to
  pushSubstsEWith' e = (pushSubstsEWith th ph e).fst


public export %inline
weakT : Term q d n -> Term q d (S n)
weakT t = t //. shift 1

public export %inline
weakE : Elim q d n -> Elim q d (S n)
weakE t = t //. shift 1


mutual
  public export
  data IsRedexT : Term q d n -> Type where
    IsUpsilonT : IsRedexT $ E (_ :# _)
    IsCloT     : IsRedexT $ CloT {}
    IsDCloT    : IsRedexT $ DCloT {}
    IsERedex   : IsRedexE e -> IsRedexT $ E e

  public export
  data IsRedexE : Elim q d n -> Type where
    IsUpsilonE : IsRedexE $ E _ :# _
    IsBetaLam  : IsRedexE $ (Lam {}  :# Pi {}) :@ _
    IsBetaDLam : IsRedexE $ (DLam {} :# Eq {}) :% _
    IsCloE     : IsRedexE $ CloE {}
    IsDCloE    : IsRedexE $ DCloE {}

public export %inline
NotRedexT : Term q d n -> Type
NotRedexT = Not . IsRedexT

public export %inline
NotRedexE : Elim q d n -> Type
NotRedexE = Not . IsRedexE


mutual
  -- [todo] PLEASE replace these with macros omfg
  export
  isRedexT : (t : Term {}) -> Dec (IsRedexT t)
  isRedexT (E (tm :# ty)) = Yes IsUpsilonT
  isRedexT (CloT {})      = Yes IsCloT
  isRedexT (DCloT {})     = Yes IsDCloT
  isRedexT (E (CloE  {})) = Yes $ IsERedex IsCloE
  isRedexT (E (DCloE {})) = Yes $ IsERedex IsDCloE
  isRedexT (E e@(_ :@ _)) with (isRedexE e)
    _ | Yes yes = Yes $ IsERedex yes
    _ | No  no  = No  $ \case IsERedex p => no p
  isRedexT (E e@(_ :% _)) with (isRedexE e)
    _ | Yes yes = Yes $ IsERedex yes
    _ | No  no  = No  $ \case IsERedex p => no p
  isRedexT (TYPE {}) = No $ \case _ impossible
  isRedexT (Pi   {}) = No $ \case _ impossible
  isRedexT (Lam  {}) = No $ \case _ impossible
  isRedexT (Eq   {}) = No $ \case _ impossible
  isRedexT (DLam {}) = No $ \case _ impossible
  isRedexT (E (F _)) = No $ \case IsERedex _ impossible
  isRedexT (E (B _)) = No $ \case IsERedex _ impossible

  export
  isRedexE : (e : Elim {}) -> Dec (IsRedexE e)
  isRedexE (E _ :# _)                    = Yes IsUpsilonE
  isRedexE ((Lam {}  :# Pi {}) :@ _)     = Yes IsBetaLam
  isRedexE ((DLam {} :# Eq {}) :% _)     = Yes IsBetaDLam
  isRedexE (CloE {})                     = Yes IsCloE
  isRedexE (DCloE {})                    = Yes IsDCloE
  isRedexE (F x)                         = No $ \case _ impossible
  isRedexE (B i)                         = No $ \case _ impossible
  isRedexE (F _                    :@ _) = No $ \case _ impossible
  isRedexE (B _                    :@ _) = No $ \case _ impossible
  isRedexE (_ :@ _                 :@ _) = No $ \case _ impossible
  isRedexE (_ :% _                 :@ _) = No $ \case _ impossible
  isRedexE (CloE {}                :@ _) = No $ \case _ impossible
  isRedexE (DCloE {}               :@ _) = No $ \case _ impossible
  isRedexE ((TYPE _   :# _)        :@ _) = No $ \case _ impossible
  isRedexE ((Pi {}    :# _)        :@ _) = No $ \case _ impossible
  isRedexE ((Eq {}    :# _)        :@ _) = No $ \case _ impossible
  isRedexE ((DLam {}  :# _)        :@ _) = No $ \case _ impossible
  isRedexE ((Lam {}   :# TYPE _)   :@ _) = No $ \case _ impossible
  isRedexE ((Lam {}   :# Lam  {})  :@ _) = No $ \case _ impossible
  isRedexE ((Lam {}   :# Eq   {})  :@ _) = No $ \case _ impossible
  isRedexE ((Lam {}   :# DLam {})  :@ _) = No $ \case _ impossible
  isRedexE ((Lam {}   :# E _)      :@ _) = No $ \case _ impossible
  isRedexE ((Lam {}   :# CloT  {}) :@ _) = No $ \case _ impossible
  isRedexE ((Lam {}   :# DCloT {}) :@ _) = No $ \case _ impossible
  isRedexE ((E _      :# _)        :@ _) = No $ \case _ impossible
  isRedexE ((CloT {}  :# _)        :@ _) = No $ \case _ impossible
  isRedexE ((DCloT {} :# _)        :@ _) = No $ \case _ impossible
  isRedexE ((TYPE _   :# _)        :% _) = No $ \case _ impossible
  isRedexE ((Pi {}    :# _)        :% _) = No $ \case _ impossible
  isRedexE ((Eq {}    :# _)        :% _) = No $ \case _ impossible
  isRedexE ((Lam {}   :# _)        :% _) = No $ \case _ impossible
  isRedexE ((DLam {}  :# TYPE _)   :% _) = No $ \case _ impossible
  isRedexE ((DLam {}  :# Pi   {})  :% _) = No $ \case _ impossible
  isRedexE ((DLam {}  :# Lam  {})  :% _) = No $ \case _ impossible
  isRedexE ((DLam {}  :# DLam {})  :% _) = No $ \case _ impossible
  isRedexE ((DLam {}  :# E _)      :% _) = No $ \case _ impossible
  isRedexE ((DLam {}  :# CloT  {}) :% _) = No $ \case _ impossible
  isRedexE ((DLam {}  :# DCloT {}) :% _) = No $ \case _ impossible
  isRedexE ((E _      :# _)        :% _) = No $ \case _ impossible
  isRedexE ((CloT {}  :# _)        :% _) = No $ \case _ impossible
  isRedexE ((DCloT {} :# _)        :% _) = No $ \case _ impossible
  isRedexE (F _                    :% _) = No $ \case _ impossible
  isRedexE (B _                    :% _) = No $ \case _ impossible
  isRedexE (_ :@ _                 :% _) = No $ \case _ impossible
  isRedexE (_ :% _                 :% _) = No $ \case _ impossible
  isRedexE (CloE {}                :% _) = No $ \case _ impossible
  isRedexE (DCloE {}               :% _) = No $ \case _ impossible
  isRedexE (TYPE _   :# _)               = No $ \case _ impossible
  isRedexE (Pi {}    :# _)               = No $ \case _ impossible
  isRedexE (Lam {}   :# _)               = No $ \case _ impossible
  isRedexE (Eq {}    :# _)               = No $ \case _ impossible
  isRedexE (DLam {}  :# _)               = No $ \case _ impossible
  isRedexE (CloT {}  :# _)               = No $ \case _ impossible
  isRedexE (DCloT {} :# _)               = No $ \case _ impossible


public export %inline
RedexTerm : Type -> Nat -> Nat -> Type
RedexTerm q d n = Subset (Term q d n) IsRedexT

public export %inline
NonRedexTerm : Type -> Nat -> Nat -> Type
NonRedexTerm q d n = Subset (Term q d n) NotRedexT

public export %inline
RedexElim : Type -> Nat -> Nat -> Type
RedexElim q d n = Subset (Elim q d n) IsRedexE

public export %inline
NonRedexElim : Type -> Nat -> Nat -> Type
NonRedexElim q d n = Subset (Elim q d n) NotRedexE


||| substitute a term with annotation for the bound variable of a `ScopeTerm`
export %inline
substScope : (arg, argTy : Term q d n) -> (body : ScopeTerm q d n) -> Term q d n
substScope arg argTy body = sub1 body (arg :# argTy)

mutual
  export %inline
  stepT' : (s : Term q d n) -> IsRedexT s -> Term q d n
  stepT' (E (s :# _)) IsUpsilonT   = s
  stepT' (CloT  s th) IsCloT       = pushSubstsTWith' id th s
  stepT' (DCloT s th) IsDCloT      = pushSubstsTWith' th id s
  stepT' (E e)        (IsERedex p) = E $ stepE' e p

  export %inline
  stepE' : (e : Elim q d n) -> IsRedexE e -> Elim q d n
  stepE' (E e :# _) IsUpsilonE = e
  stepE' ((Lam {body, _} :# Pi {arg, res, _}) :@ s) IsBetaLam =
    let s = s :# arg in sub1 body s :# sub1 res s
  stepE' ((DLam {body, _} :# Eq {ty, l, r, _}) :% dim) IsBetaDLam =
    case dim of
      K Zero => l :# ty.zero
      K One  => r :# ty.one
      B _    => dsub1 body dim :# dsub1 ty dim
  stepE' (CloE  e th) IsCloE  = pushSubstsEWith' id th e
  stepE' (DCloE e th) IsDCloE = pushSubstsEWith' th id e

export %inline
stepT : (s : Term q d n) -> Either (NotRedexT s) (Term q d n)
stepT s = case isRedexT s of Yes y => Right $ stepT' s y; No n => Left n

export %inline
stepE : (e : Elim q d n) -> Either (NotRedexE e) (Elim q d n)
stepE e = case isRedexE e of Yes y => Right $ stepE' e y; No n => Left n

export covering
whnfT : Term q d n -> NonRedexTerm q d n
whnfT s = case stepT s of Right s' => whnfT s'; Left done => Element s done

export covering
whnfE : Elim q d n -> NonRedexElim q d n
whnfE e = case stepE e of Right e' => whnfE e'; Left done => Element e done


export
notRedexNotCloE : (e : Elim {}) -> NotRedexE e -> NotCloE e
notRedexNotCloE (F x)         f = NCF
notRedexNotCloE (B i)         f = NCB
notRedexNotCloE (fun :@ arg)  f = NCApp
notRedexNotCloE (fun :% arg)  f = NCDApp
notRedexNotCloE (tm :# ty)    f = NCAnn
notRedexNotCloE (CloE el th)  f = absurd $ f IsCloE
notRedexNotCloE (DCloE el th) f = absurd $ f IsDCloE

export
notRedexNotCloT : (t : Term {}) -> NotRedexT t -> NotCloT t
notRedexNotCloT (TYPE _)   _ = NCTYPE
notRedexNotCloT (Pi {})    _ = NCPi
notRedexNotCloT (Lam {})   _ = NCLam
notRedexNotCloT (Eq {})    _ = NCEq
notRedexNotCloT (DLam {})  _ = NCDLam
notRedexNotCloT (E e)      f = NCE $ notRedexNotCloE e $ f . IsERedex
notRedexNotCloT (CloT  {}) f = absurd $ f IsCloT
notRedexNotCloT (DCloT {}) f = absurd $ f IsDCloT

export
toNotCloE : NonRedexElim q d n -> NonCloElim q d n
toNotCloE (Element e prf) = Element e $ notRedexNotCloE e prf

export
toNotCloT : NonRedexTerm q d n -> NonCloTerm q d n
toNotCloT (Element t prf) = Element t $ notRedexNotCloT t prf