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

373 lines
12 KiB
Idris
Raw Normal View History

module Quox.Syntax.Term.Tighten
import Quox.Syntax.Term.Base
import Quox.Syntax.Term.Subst
import public Quox.OPE
import Quox.No
%default total
2023-05-01 21:06:25 -04:00
export
Tighten Dim where
tighten p (K e loc) = pure $ K e loc
tighten p (B i loc) = B <$> tighten p i <*> pure loc
export
tightenScope : (forall m, n. OPE m n -> f n -> Maybe (f m)) ->
{s : Nat} -> OPE m n -> Scoped s f n -> Maybe (Scoped s f m)
tightenScope f p (S names (Y body)) = SY names <$> f (keepN s p) body
tightenScope f p (S names (N body)) = S names . N <$> f p body
export
tightenDScope : {0 f : Nat -> Nat -> Type} ->
(forall m, n, k. OPE m n -> f n k -> Maybe (f m k)) ->
OPE m n -> Scoped s (f n) k -> Maybe (Scoped s (f m) k)
tightenDScope f p (S names (Y body)) = SY names <$> f p body
tightenDScope f p (S names (N body)) = S names . N <$> f p body
mutual
private
tightenT : OPE n1 n2 -> Term d n2 -> Maybe (Term d n1)
tightenT p s =
let Element s' _ = pushSubsts s in
tightenT' p $ assert_smaller s s'
private
tightenE : OPE n1 n2 -> Elim d n2 -> Maybe (Elim d n1)
tightenE p e =
let Element e' _ = pushSubsts e in
tightenE' p $ assert_smaller e e'
private
tightenT' : OPE n1 n2 -> (t : Term d n2) -> (0 nt : NotClo t) =>
Maybe (Term d n1)
tightenT' p (TYPE l loc) = pure $ TYPE l loc
tightenT' p (IOState loc) = pure $ IOState loc
tightenT' p (Pi qty arg res loc) =
2023-05-01 21:06:25 -04:00
Pi qty <$> tightenT p arg <*> tightenS p res <*> pure loc
tightenT' p (Lam body loc) =
2023-05-01 21:06:25 -04:00
Lam <$> tightenS p body <*> pure loc
tightenT' p (Sig fst snd loc) =
2023-05-01 21:06:25 -04:00
Sig <$> tightenT p fst <*> tightenS p snd <*> pure loc
tightenT' p (Pair fst snd loc) =
2023-05-01 21:06:25 -04:00
Pair <$> tightenT p fst <*> tightenT p snd <*> pure loc
tightenT' p (Enum cases loc) =
2023-05-01 21:06:25 -04:00
pure $ Enum cases loc
tightenT' p (Tag tag loc) =
2023-05-01 21:06:25 -04:00
pure $ Tag tag loc
tightenT' p (Eq ty l r loc) =
2023-05-01 21:06:25 -04:00
Eq <$> tightenDS p ty <*> tightenT p l <*> tightenT p r <*> pure loc
tightenT' p (DLam body loc) =
2023-05-01 21:06:25 -04:00
DLam <$> tightenDS p body <*> pure loc
2023-11-02 13:14:22 -04:00
tightenT' p (NAT loc) =
pure $ NAT loc
tightenT' p (Nat n loc) =
pure $ Nat n loc
tightenT' p (Succ s loc) =
2023-05-01 21:06:25 -04:00
Succ <$> tightenT p s <*> pure loc
tightenT' p (STRING loc) =
pure $ STRING loc
tightenT' p (Str s loc) =
pure $ Str s loc
tightenT' p (BOX qty ty loc) =
2023-05-01 21:06:25 -04:00
BOX qty <$> tightenT p ty <*> pure loc
tightenT' p (Box val loc) =
2023-05-01 21:06:25 -04:00
Box <$> tightenT p val <*> pure loc
tightenT' p (E e) =
2023-05-01 21:06:25 -04:00
assert_total $ E <$> tightenE p e
private
tightenE' : OPE n1 n2 -> (e : Elim d n2) -> (0 ne : NotClo e) =>
Maybe (Elim d n1)
tightenE' p (F x u loc) =
2023-05-21 14:09:34 -04:00
pure $ F x u loc
tightenE' p (B i loc) =
2023-05-01 21:06:25 -04:00
B <$> tighten p i <*> pure loc
tightenE' p (App fun arg loc) =
2023-05-01 21:06:25 -04:00
App <$> tightenE p fun <*> tightenT p arg <*> pure loc
tightenE' p (CasePair qty pair ret body loc) =
CasePair qty <$> tightenE p pair
<*> tightenS p ret
<*> tightenS p body
2023-05-01 21:06:25 -04:00
<*> pure loc
2023-09-18 15:52:51 -04:00
tightenE' p (Fst pair loc) =
Fst <$> tightenE p pair <*> pure loc
tightenE' p (Snd pair loc) =
Snd <$> tightenE p pair <*> pure loc
tightenE' p (CaseEnum qty tag ret arms loc) =
CaseEnum qty <$> tightenE p tag
<*> tightenS p ret
<*> traverse (tightenT p) arms
2023-05-01 21:06:25 -04:00
<*> pure loc
tightenE' p (CaseNat qty qtyIH nat ret zero succ loc) =
CaseNat qty qtyIH
<$> tightenE p nat
<*> tightenS p ret
<*> tightenT p zero
<*> tightenS p succ
2023-05-01 21:06:25 -04:00
<*> pure loc
tightenE' p (CaseBox qty box ret body loc) =
CaseBox qty <$> tightenE p box
<*> tightenS p ret
<*> tightenS p body
2023-05-01 21:06:25 -04:00
<*> pure loc
tightenE' p (DApp fun arg loc) =
2023-05-01 21:06:25 -04:00
DApp <$> tightenE p fun <*> pure arg <*> pure loc
tightenE' p (Ann tm ty loc) =
2023-05-01 21:06:25 -04:00
Ann <$> tightenT p tm <*> tightenT p ty <*> pure loc
tightenE' p (Coe ty q0 q1 val loc) =
Coe <$> tightenDS p ty
<*> pure q0 <*> pure q1
<*> tightenT p val
2023-05-01 21:06:25 -04:00
<*> pure loc
tightenE' p (Comp ty q0 q1 val r zero one loc) =
Comp <$> tightenT p ty
<*> pure q0 <*> pure q1
<*> tightenT p val
<*> pure r
<*> tightenDS p zero
<*> tightenDS p one
2023-05-01 21:06:25 -04:00
<*> pure loc
tightenE' p (TypeCase ty ret arms def loc) =
TypeCase <$> tightenE p ty
<*> tightenT p ret
<*> traverse (tightenS p) arms
<*> tightenT p def
2023-05-01 21:06:25 -04:00
<*> pure loc
export
tightenS : {s : Nat} -> OPE m n ->
ScopeTermN s f n -> Maybe (ScopeTermN s f m)
tightenS = assert_total $ tightenScope tightenT
export
tightenDS : OPE m n -> DScopeTermN s f n -> Maybe (DScopeTermN s f m)
tightenDS = assert_total $ tightenDScope tightenT {f = \n, d => Term d n}
export Tighten (Elim d) where tighten p e = tightenE p e
export Tighten (Term d) where tighten p t = tightenT p t
mutual
export
dtightenT : OPE d1 d2 -> Term d2 n -> Maybe (Term d1 n)
dtightenT p s =
let Element s' _ = pushSubsts s in
dtightenT' p $ assert_smaller s s'
export
dtightenE : OPE d1 d2 -> Elim d2 n -> Maybe (Elim d1 n)
dtightenE p e =
let Element e' _ = pushSubsts e in
dtightenE' p $ assert_smaller e e'
private
dtightenT' : OPE d1 d2 -> (t : Term d2 n) -> (0 nt : NotClo t) =>
Maybe (Term d1 n)
dtightenT' p (TYPE l loc) =
2023-05-01 21:06:25 -04:00
pure $ TYPE l loc
dtightenT' p (IOState loc) =
pure $ IOState loc
dtightenT' p (Pi qty arg res loc) =
2023-05-01 21:06:25 -04:00
Pi qty <$> dtightenT p arg <*> dtightenS p res <*> pure loc
dtightenT' p (Lam body loc) =
2023-05-01 21:06:25 -04:00
Lam <$> dtightenS p body <*> pure loc
dtightenT' p (Sig fst snd loc) =
2023-05-01 21:06:25 -04:00
Sig <$> dtightenT p fst <*> dtightenS p snd <*> pure loc
dtightenT' p (Pair fst snd loc) =
2023-05-01 21:06:25 -04:00
Pair <$> dtightenT p fst <*> dtightenT p snd <*> pure loc
dtightenT' p (Enum cases loc) =
2023-05-01 21:06:25 -04:00
pure $ Enum cases loc
dtightenT' p (Tag tag loc) =
2023-05-01 21:06:25 -04:00
pure $ Tag tag loc
dtightenT' p (Eq ty l r loc) =
2023-05-01 21:06:25 -04:00
Eq <$> dtightenDS p ty <*> dtightenT p l <*> dtightenT p r <*> pure loc
dtightenT' p (DLam body loc) =
2023-05-01 21:06:25 -04:00
DLam <$> dtightenDS p body <*> pure loc
2023-11-02 13:14:22 -04:00
dtightenT' p (NAT loc) =
pure $ NAT loc
dtightenT' p (Nat n loc) =
pure $ Nat n loc
dtightenT' p (Succ s loc) =
2023-05-01 21:06:25 -04:00
Succ <$> dtightenT p s <*> pure loc
dtightenT' p (STRING loc) =
pure $ STRING loc
dtightenT' p (Str s loc) =
pure $ Str s loc
dtightenT' p (BOX qty ty loc) =
2023-05-01 21:06:25 -04:00
BOX qty <$> dtightenT p ty <*> pure loc
dtightenT' p (Box val loc) =
2023-05-01 21:06:25 -04:00
Box <$> dtightenT p val <*> pure loc
dtightenT' p (E e) =
2023-05-01 21:06:25 -04:00
assert_total $ E <$> dtightenE p e
export
dtightenE' : OPE d1 d2 -> (e : Elim d2 n) -> (0 ne : NotClo e) =>
Maybe (Elim d1 n)
dtightenE' p (F x u loc) =
2023-05-21 14:09:34 -04:00
pure $ F x u loc
dtightenE' p (B i loc) =
2023-05-01 21:06:25 -04:00
pure $ B i loc
dtightenE' p (App fun arg loc) =
2023-05-01 21:06:25 -04:00
App <$> dtightenE p fun <*> dtightenT p arg <*> pure loc
dtightenE' p (CasePair qty pair ret body loc) =
CasePair qty <$> dtightenE p pair
<*> dtightenS p ret
<*> dtightenS p body
2023-05-01 21:06:25 -04:00
<*> pure loc
2023-09-18 15:52:51 -04:00
dtightenE' p (Fst pair loc) =
Fst <$> dtightenE p pair <*> pure loc
dtightenE' p (Snd pair loc) =
Snd <$> dtightenE p pair <*> pure loc
dtightenE' p (CaseEnum qty tag ret arms loc) =
CaseEnum qty <$> dtightenE p tag
<*> dtightenS p ret
<*> traverse (dtightenT p) arms
2023-05-01 21:06:25 -04:00
<*> pure loc
dtightenE' p (CaseNat qty qtyIH nat ret zero succ loc) =
CaseNat qty qtyIH
<$> dtightenE p nat
<*> dtightenS p ret
<*> dtightenT p zero
<*> dtightenS p succ
2023-05-01 21:06:25 -04:00
<*> pure loc
dtightenE' p (CaseBox qty box ret body loc) =
CaseBox qty <$> dtightenE p box
<*> dtightenS p ret
<*> dtightenS p body
2023-05-01 21:06:25 -04:00
<*> pure loc
dtightenE' p (DApp fun arg loc) =
2023-05-01 21:06:25 -04:00
DApp <$> dtightenE p fun <*> tighten p arg <*> pure loc
dtightenE' p (Ann tm ty loc) =
2023-05-01 21:06:25 -04:00
Ann <$> dtightenT p tm <*> dtightenT p ty <*> pure loc
dtightenE' p (Coe ty q0 q1 val loc) =
2023-05-01 21:06:25 -04:00
[|Coe (dtightenDS p ty) (tighten p q0) (tighten p q1) (dtightenT p val)
(pure loc)|]
dtightenE' p (Comp ty q0 q1 val r zero one loc) =
[|Comp (dtightenT p ty) (tighten p q0) (tighten p q1)
(dtightenT p val) (tighten p r)
2023-05-01 21:06:25 -04:00
(dtightenDS p zero) (dtightenDS p one) (pure loc)|]
dtightenE' p (TypeCase ty ret arms def loc) =
[|TypeCase (dtightenE p ty) (dtightenT p ret)
2023-05-01 21:06:25 -04:00
(traverse (dtightenS p) arms) (dtightenT p def) (pure loc)|]
export
dtightenS : OPE d1 d2 -> ScopeTermN s d2 n -> Maybe (ScopeTermN s d1 n)
dtightenS = assert_total $ tightenDScope dtightenT {f = Term}
export
dtightenDS : {s : Nat} -> OPE d1 d2 ->
DScopeTermN s d2 n -> Maybe (DScopeTermN s d1 n)
dtightenDS = assert_total $ tightenScope dtightenT
2023-09-17 07:54:26 -04:00
export Tighten (\d => Term d n) where tighten p t = dtightenT p t
export Tighten (\d => Elim d n) where tighten p e = dtightenE p e
parameters {auto _ : Tighten f} {s : Nat}
export
2023-09-17 13:06:07 -04:00
squeeze : Scoped s f n -> (BContext s, Either (f (s + n)) (f n))
squeeze (S ns (N t)) = (ns, Right t)
squeeze (S ns (Y t)) = (ns, maybe (Left t) Right $ tightenN s t)
2023-09-17 07:54:26 -04:00
export
squeeze' : Scoped s f n -> Scoped s f n
2023-09-17 13:06:07 -04:00
squeeze' t = let (ns, res) = squeeze t in S ns $ either Y N res
2023-09-17 07:54:26 -04:00
parameters {0 f : Nat -> Nat -> Type}
{auto tt : Tighten (\d => f d n)} {s : Nat}
export
dsqueeze : Scoped s (\d => f d n) d ->
2023-09-17 13:06:07 -04:00
(BContext s, Either (f (s + d) n) (f d n))
2023-09-17 07:54:26 -04:00
dsqueeze = squeeze
export
dsqueeze' : Scoped s (\d => f d n) d -> Scoped s (\d => f d n) d
dsqueeze' = squeeze'
-- versions of SY, etc, that try to tighten and use SN automatically
2023-09-17 13:06:07 -04:00
public export %inline
2023-05-01 21:06:25 -04:00
ST : Tighten f => {s : Nat} -> BContext s -> f (s + n) -> Scoped s f n
2023-09-17 07:54:26 -04:00
ST names body = squeeze' $ SY names body
2023-09-17 13:06:07 -04:00
public export %inline
2023-05-01 21:06:25 -04:00
DST : {s : Nat} -> BContext s -> Term (s + d) n -> DScopeTermN s d n
2023-09-17 07:54:26 -04:00
DST names body = dsqueeze' {f = Term} $ SY names body
public export %inline
2023-05-01 21:06:25 -04:00
PiT : (qty : Qty) -> (x : BindName) ->
(arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n
PiT {qty, x, arg, res, loc} = Pi {qty, arg, res = ST [< x] res, loc}
public export %inline
LamT : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n
LamT {x, body, loc} = Lam {body = ST [< x] body, loc}
public export %inline
SigT : (x : BindName) -> (fst : Term d n) ->
(snd : Term d (S n)) -> (loc : Loc) -> Term d n
SigT {x, fst, snd, loc} = Sig {fst, snd = ST [< x] snd, loc}
public export %inline
2023-05-01 21:06:25 -04:00
EqT : (i : BindName) -> (ty : Term (S d) n) ->
(l, r : Term d n) -> (loc : Loc) -> Term d n
EqT {i, ty, l, r, loc} = Eq {ty = DST [< i] ty, l, r, loc}
public export %inline
2023-05-01 21:06:25 -04:00
DLamT : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n
DLamT {i, body, loc} = DLam {body = DST [< i] body, loc}
public export %inline
2023-05-01 21:06:25 -04:00
CoeT : (i : BindName) -> (ty : Term (S d) n) ->
(p, q : Dim d) -> (val : Term d n) -> (loc : Loc) -> Elim d n
CoeT {i, ty, p, q, val, loc} = Coe {ty = DST [< i] ty, p, q, val, loc}
public export %inline
typeCase1T : Elim d n -> Term d n ->
2023-05-01 21:06:25 -04:00
(k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) ->
(loc : Loc) ->
2023-11-02 13:14:22 -04:00
{default (NAT loc) def : Term d n} ->
Elim d n
2023-05-01 21:06:25 -04:00
typeCase1T ty ret k ns body loc {def} =
typeCase ty ret [(k ** ST ns body)] def loc
public export %inline
CompH' : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) ->
(r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n
CompH' {ty, p, q, val, r, zero, one, loc} =
2023-09-17 07:54:26 -04:00
let ty' = DST ty.names $ ty.term // (B VZ ty.name.loc ::: shift 2) in
Comp {
ty = dsub1 ty q, p, q,
val = E $ Coe ty p q val val.loc, r,
zero = DST zero.names $ E $
Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc,
one = DST one.names $ E $
Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc,
loc
}
||| heterogeneous composition, using Comp and Coe (and subst)
|||
||| comp [i ⇒ A] @p @q s @r { 0 j ⇒ t₀; 1 j ⇒ t₁ }
||| ≔
||| comp [Aq/i] @p @q (coe [i ⇒ A] @p @q s) @r {
||| 0 j ⇒ coe [i ⇒ A] @j @q t₀;
||| 1 j ⇒ coe [i ⇒ A] @j @q t₁
||| }
public export %inline
CompH : (i : BindName) -> (ty : Term (S d) n) ->
(p, q : Dim d) -> (val : Term d n) -> (r : Dim d) ->
(j0 : BindName) -> (zero : Term (S d) n) ->
(j1 : BindName) -> (one : Term (S d) n) ->
(loc : Loc) ->
Elim d n
CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} =
CompH' {ty = DST [< i] ty, p, q, val, r,
zero = DST [< j0] zero, one = DST [< j1] one, loc}