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

module Quox.Syntax.Term.Subst

import Quox.Syntax.Term.Base

%default total


export FromVar (Elim q d) where fromVar = B
export FromVar (Term q d) where fromVar = E . fromVar

||| does the minimal reasonable work:
||| - deletes the closure around a free name since it doesn't do anything
||| - deletes an identity substitution
||| - composes (lazily) with an existing top-level closure
||| - immediately looks up a bound variable
||| - otherwise, wraps in a new closure
export
CanSubst (Elim q d) (Elim q d) where
  F x       // _  = F x
  B i       // th = th !! i
  CloE e ph // th = assert_total CloE e $ ph . th
  e         // th = case force th of
                         Shift SZ => e
                         th       => CloE e th

||| does the minimal reasonable work:
||| - deletes the closure around an atomic constant like `TYPE`
||| - deletes an identity substitution
||| - composes (lazily) with an existing top-level closure
||| - goes inside `E` in case it is a simple variable or something
||| - otherwise, wraps in a new closure
export
CanSubst (Elim q d) (Term q d) where
  TYPE l    // _  = TYPE l
  E e       // th = E $ e // th
  CloT s ph // th = CloT s $ ph . th
  s         // th = case force th of
                         Shift SZ => s
                         th       => CloT s th

export
CanSubst (Elim q d) (ScopeTerm q d) where
  TUsed   body // th = TUsed   $ body // push th
  TUnused body // th = TUnused $ body // th

export CanSubst Var (Term      q d) where s // th = s // map (B {q, d}) th
export CanSubst Var (Elim      q d) where e // th = e // map (B {q, d}) th
export CanSubst Var (ScopeTerm q d) where s // th = s // map (B {q, d}) th


infixl 8 //., ///
mutual
  namespace Term
    ||| applies a term substitution with a less ambiguous type
    export
    (//.) : Term q d from -> TSubst q d from to -> Term q d to
    t //. th = t // th

    ||| applies a dimension substitution with the same behaviour as `(//)`
    ||| above
    export
    (///) : Term q dfrom n -> DSubst dfrom dto -> Term q dto n
    TYPE l     /// _        = TYPE l
    E e        /// th       = E $ e /// th
    DCloT s ph /// th       = DCloT s $ ph . th
    s          /// Shift SZ = s
    s          /// th       = DCloT s th

    ||| applies a term and dimension substitution
    public export %inline
    subs : Term q dfrom from -> DSubst dfrom dto -> TSubst q dto from to ->
           Term q dto to
    subs s th ph = s /// th // ph

  namespace Elim
    ||| applies a term substitution with a less ambiguous type
    export
    (//.) : Elim q d from -> TSubst q d from to -> Elim q d to
    e //. th = e // th

    ||| applies a dimension substitution with the same behaviour as `(//)`
    ||| above
    export
    (///) : Elim q dfrom n -> DSubst dfrom dto -> Elim q dto n
    F x        /// _        = F x
    B i        /// _        = B i
    DCloE e ph /// th       = DCloE e $ ph . th
    e          /// Shift SZ = e
    e          /// th       = DCloE e th

    ||| applies a term and dimension substitution
    public export %inline
    subs : Elim q dfrom from -> DSubst dfrom dto -> TSubst q dto from to ->
           Elim q dto to
    subs e th ph = e /// th // ph

  namespace ScopeTerm
    ||| applies a term substitution with a less ambiguous type
    export
    (//.) : ScopeTerm q d from -> TSubst q d from to -> ScopeTerm q d to
    body //. th = body // th

    ||| applies a dimension substitution with the same behaviour as `(//)`
    ||| above
    export
    (///) : ScopeTerm q dfrom n -> DSubst dfrom dto -> ScopeTerm q dto n
    TUsed   body /// th = TUsed   $ body /// th
    TUnused body /// th = TUnused $ body /// th

    ||| applies a term and dimension substitution
    public export %inline
    subs : ScopeTerm q dfrom from -> DSubst dfrom dto -> TSubst q dto from to ->
           ScopeTerm q dto to
    subs body th ph = body /// th // ph

export CanShift (Term      q d) where s // by = s //. Shift by
export CanShift (Elim      q d) where e // by = e //. Shift by
export CanShift (ScopeTerm q d) where s // by = s //. Shift by


export %inline
comp' : DSubst dfrom dto -> TSubst q dfrom from mid -> TSubst q dto mid to ->
        TSubst q dto from to
comp' th ps ph = map (/// th) ps . ph


export
fromDScopeTerm : DScopeTerm q d n -> Term q (S d) n
fromDScopeTerm (DUsed   body) = body
fromDScopeTerm (DUnused body) = body /// shift 1

export
fromScopeTerm : ScopeTerm q d n -> Term q d (S n)
fromScopeTerm (TUsed   body) = body
fromScopeTerm (TUnused body) = body //. shift 1