diff --git a/src/Quox/Syntax/Term.idr b/src/Quox/Syntax/Term.idr index 4125693..58eac95 100644 --- a/src/Quox/Syntax/Term.idr +++ b/src/Quox/Syntax/Term.idr @@ -36,9 +36,9 @@ mutual ||| function type Pi : (qtm, qty : Qty) -> (x : Name) -> - (arg : Term d n) -> (res : Term d (S n)) -> Term d n + (arg : Term d n) -> (res : ScopeTerm d n) -> Term d n ||| function term - Lam : (x : Name) -> (body : Term d (S n)) -> Term d n + Lam : (x : Name) -> (body : ScopeTerm d n) -> Term d n ||| elimination E : (e : Elim d n) -> Term d n @@ -67,8 +67,36 @@ mutual ||| dimension closure/suspended substitution DCloE : (el : Elim dfrom n) -> (th : Lazy (DSubst dfrom dto)) -> Elim dto n + ||| a scope with one more bound variable + public export + data ScopeTerm : (d, n : Nat) -> Type where + ||| variable is used + TUsed : (body : Term d (S n)) -> ScopeTerm d n + ||| variable is unused + TUnused : (body : Term d n) -> ScopeTerm d n + + ||| a scope with one more bound dimension variable + public export + data DScopeTerm : (d, n : Nat) -> Type where + ||| variable is used + DUsed : (body : Term (S d) n) -> DScopeTerm d n + ||| variable is unused + DUnused : (body : Term d n) -> DScopeTerm d n + %name Term s, t, r %name Elim e, f +%name ScopeTerm body +%name DScopeTerm body + +export +fromDScopeTerm : DScopeTerm d n -> Term (S d) n +fromDScopeTerm (DUsed body) = body +fromDScopeTerm (DUnused body) = body `DCloT` shift 1 + +export +fromScopeTerm : ScopeTerm d n -> Term d (S n) +fromScopeTerm (TUsed body) = body +fromScopeTerm (TUnused body) = body `CloT` shift 1 ||| same as `F` but as a term @@ -139,7 +167,7 @@ public export (:\\) : Vect m Name -> Term d (m + n) -> Term d n [] :\\ t = t x :: xs :\\ t = let t' = replace {p = Term _} (plusSuccRightSucc {}) t in - Lam x $ xs :\\ t' + Lam x $ TUsed $ xs :\\ t' public export record GetLams (d, n : Nat) where @@ -152,8 +180,8 @@ record GetLams (d, n : Nat) where public export getLams : Term d n -> GetLams d n getLams s with (choose $ isLam s) - getLams (Lam x s) | Left yes = - let inner = getLams s in + getLams s@(Lam x body) | Left yes = + let inner = getLams $ assert_smaller s $ fromScopeTerm body in GotLams {names = x :: inner.names, body = inner.body, eq = plusSuccRightSucc {} `trans` inner.eq, @@ -220,6 +248,10 @@ mutual parensIfM SApp . hang 2 =<< [|withPrec SApp (prettyM e) prettyDSubst th|] + export covering + PrettyHL (ScopeTerm d n) where + prettyM body = prettyM $ fromScopeTerm body + export covering prettyTSubst : Pretty.HasEnv m => TSubst d from to -> m (Doc HL) prettyTSubst s = prettySubstM prettyM (!ask).tnames TVar "[" "]" s @@ -266,11 +298,18 @@ CanSubst (Elim d) (Term d) where Shift SZ => s th => CloT s th -export CanSubst Var (Term d) where s // th = s // map (B {d}) th -export CanSubst Var (Elim d) where e // th = e // map (B {d}) th +export +CanSubst (Elim d) (ScopeTerm d) where + TUsed body // th = TUsed $ body // push th + TUnused body // th = TUnused $ body // th -export CanShift (Term d) where i // by = i // Shift by {env = Elim d} -export CanShift (Elim d) where i // by = i // Shift by {env = Elim d} +export CanSubst Var (Term d) where s // th = s // map (B {d}) th +export CanSubst Var (Elim d) where e // th = e // map (B {d}) th +export CanSubst Var (ScopeTerm d) where s // th = s // map (B {d}) th + +export CanShift (Term d) where s // by = s // Shift by {env = Elim d} +export CanShift (Elim d) where e // by = e // Shift by {env = Elim d} +export CanShift (ScopeTerm d) where s // by = s // Shift by {env = Elim d} infixl 8 /// @@ -309,6 +348,20 @@ mutual Elim dto to subs e th ph = e /// th // ph + namespace ScopeTerm + ||| applies a dimension substitution with the same behaviour as `(//)` + ||| above + export + (///) : ScopeTerm dfrom n -> DSubst dfrom dto -> ScopeTerm 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 dfrom from -> DSubst dfrom dto -> TSubst dto from to -> + ScopeTerm dto to + subs body th ph = body /// th // ph + private %inline comp' : DSubst dfrom dto -> TSubst dfrom from mid -> TSubst dto mid to -> @@ -376,10 +429,10 @@ mutual Term dfrom from -> NotCloTerm dto to pushSubstsTWith th ph (TYPE l) = ncloT $ TYPE l - pushSubstsTWith th ph (Pi qtm qty x a b) = - ncloT $ Pi qtm qty x (subs a th ph) (subs b th (push ph)) - pushSubstsTWith th ph (Lam x t) = - ncloT $ Lam x $ subs t th $ push ph + pushSubstsTWith th ph (Pi qtm qty x a body) = + ncloT $ Pi qtm 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 (E e) = let Element e _ = pushSubstsEWith th ph e in ncloT $ E e pushSubstsTWith th ph (CloT s ps) = @@ -501,6 +554,12 @@ NonRedexElim : Nat -> Nat -> Type NonRedexElim d n = Subset (Elim d n) NotRedexE +||| substitute a term with annotation for the bound variable of a `ScopeTerm` +public export %inline +substScope : (arg, argTy : Term d n) -> (body : ScopeTerm d n) -> Term d n +substScope arg argTy (TUsed body) = body // one (arg :# argTy) +substScope arg argTy (TUnused body) = body + public export %inline stepT' : (s : Term d n) -> IsRedexT s -> Term d n stepT' (E (s :# _)) IsUpsilon = s @@ -514,7 +573,7 @@ stepT s = case isRedexT s of Yes y => Right $ stepT' s y; No n => Left n public export %inline stepE' : (e : Elim d n) -> IsRedexE e -> Elim d n stepE' ((Lam {body, _} :# Pi {arg, res, _}) :@ s) IsBetaLam = - (body :# res) // one (s :# arg) + substScope s arg body :# substScope s arg res stepE' (CloE e th) IsCloE = pushSubstsEWith' id th e stepE' (DCloE e th) IsDCloE = pushSubstsEWith' th id e