162 lines
4.3 KiB
Idris
162 lines
4.3 KiB
Idris
module Quox.Syntax.Subst
|
|
|
|
import public Quox.Syntax.Shift
|
|
import Quox.Syntax.Var
|
|
import Quox.Name
|
|
|
|
import Data.Nat
|
|
import Data.List
|
|
import Data.SnocVect
|
|
import Derive.Prelude
|
|
|
|
%default total
|
|
%language ElabReflection
|
|
|
|
|
|
public export
|
|
data Subst : (Nat -> Type) -> Nat -> Nat -> Type where
|
|
Shift : Shift from to -> Subst env from to
|
|
(:::) : (t : Lazy (env to)) -> Subst env from to -> Subst env (S from) to
|
|
%name Subst th, ph, ps
|
|
|
|
infixr 7 !:::
|
|
||| in case the automatic laziness insertion gets confused
|
|
public export
|
|
(!:::) : env to -> Subst env from to -> Subst env (S from) to
|
|
t !::: ts = t ::: ts
|
|
|
|
|
|
private
|
|
Repr : (Nat -> Type) -> Nat -> Type
|
|
Repr f to = (List (f to), Nat)
|
|
|
|
private
|
|
repr : Subst f from to -> Repr f to
|
|
repr (Shift by) = ([], by.nat)
|
|
repr (t ::: th) = let (ts, i) = repr th in (t::ts, i)
|
|
|
|
|
|
export Eq (f to) => Eq (Subst f from to) where (==) = (==) `on` repr
|
|
export Ord (f to) => Ord (Subst f from to) where compare = compare `on` repr
|
|
export Show (f to) => Show (Subst f from to) where show = show . repr
|
|
|
|
|
|
infixl 8 //
|
|
public export
|
|
interface FromVar term => CanSubstSelf term where
|
|
(//) : term from -> Lazy (Subst term from to) -> term to
|
|
|
|
|
|
public export
|
|
getLoc : FromVar term => Subst term from to -> Var from -> Loc -> term to
|
|
getLoc (Shift by) i loc = fromVarLoc (shift by i) loc
|
|
getLoc (t ::: th) VZ _ = t
|
|
getLoc (t ::: th) (VS i) loc = getLoc th i loc
|
|
|
|
|
|
public export
|
|
CanSubstSelf Var where
|
|
i // Shift by = shift by i
|
|
VZ // (t ::: th) = t
|
|
VS i // (t ::: th) = i // th
|
|
|
|
|
|
public export %inline
|
|
shift : (by : Nat) -> Subst env from (by + from)
|
|
shift by = Shift $ fromNat by
|
|
|
|
public export %inline
|
|
shift0 : (by : Nat) -> Subst env 0 by
|
|
shift0 by = rewrite sym $ plusZeroRightNeutral by in Shift $ fromNat by
|
|
|
|
|
|
public export
|
|
(.) : CanSubstSelf f => Subst f from mid -> Subst f mid to -> Subst f from to
|
|
Shift by . Shift bz = Shift $ by . bz
|
|
Shift SZ . ph = ph
|
|
Shift (SS by) . (t ::: th) = Shift by . th
|
|
(t ::: th) . ph = (t // ph) ::: (th . ph)
|
|
|
|
public export %inline
|
|
id : Subst f n n
|
|
id = shift 0
|
|
|
|
public export
|
|
traverse : Applicative m =>
|
|
(f to -> m (g to)) -> Subst f from to -> m (Subst g from to)
|
|
traverse f (Shift by) = pure $ Shift by
|
|
traverse f (t ::: th) = [|f t !::: traverse f th|]
|
|
|
|
-- not in terms of traverse because this map can maintain laziness better
|
|
public export
|
|
map : (f to -> g to) -> Subst f from to -> Subst g from to
|
|
map f (Shift by) = Shift by
|
|
map f (t ::: th) = f t ::: map f th
|
|
|
|
|
|
public export %inline
|
|
push : CanSubstSelf f => Subst f from to -> Subst f (S from) (S to)
|
|
push th = fromVar VZ ::: (th . shift 1)
|
|
|
|
-- [fixme] a better way to do this?
|
|
public export
|
|
pushN : CanSubstSelf f => (s : Nat) ->
|
|
Subst f from to -> Subst f (s + from) (s + to)
|
|
pushN 0 th = th
|
|
pushN (S s) th =
|
|
rewrite plusSuccRightSucc s from in
|
|
rewrite plusSuccRightSucc s to in
|
|
pushN s $ fromVar VZ ::: (th . shift 1)
|
|
|
|
public export
|
|
drop1 : Subst f (S from) to -> Subst f from to
|
|
drop1 (Shift by) = Shift $ ssDown by
|
|
drop1 (t ::: th) = th
|
|
|
|
|
|
public export
|
|
fromSnocVect : SnocVect s (f n) -> Subst f (s + n) n
|
|
fromSnocVect [<] = id
|
|
fromSnocVect (xs :< x) = x ::: fromSnocVect xs
|
|
|
|
public export %inline
|
|
one : f n -> Subst f (S n) n
|
|
one x = fromSnocVect [< x]
|
|
|
|
|
|
||| whether two substitutions with the same codomain have the same shape
|
|
||| (the same number of terms and the same shift at the end). if so, they
|
|
||| also have the same domain
|
|
export
|
|
cmpShape : Subst env from1 to -> Subst env from2 to ->
|
|
Either Ordering (from1 = from2)
|
|
cmpShape (Shift by) (Shift bz) = cmpLen by bz
|
|
cmpShape (Shift _) (_ ::: _) = Left LT
|
|
cmpShape (_ ::: _) (Shift _) = Left GT
|
|
cmpShape (_ ::: th) (_ ::: ph) = map (\x => cong S x) $ cmpShape th ph
|
|
|
|
|
|
public export
|
|
record WithSubst tm env n where
|
|
constructor Sub
|
|
term : tm from
|
|
subst : Lazy (Subst env from n)
|
|
|
|
export
|
|
(Eq (env n), forall n. Eq (tm n)) => Eq (WithSubst tm env n) where
|
|
Sub t1 s1 == Sub t2 s2 =
|
|
case cmpShape s1 s2 of
|
|
Left _ => False
|
|
Right Refl => t1 == t2 && s1 == s2
|
|
|
|
export
|
|
(Ord (env n), forall n. Ord (tm n)) => Ord (WithSubst tm env n) where
|
|
Sub t1 s1 `compare` Sub t2 s2 =
|
|
case cmpShape s1 s2 of
|
|
Left o => o
|
|
Right Refl => compare (t1, s1) (t2, s2)
|
|
|
|
export %hint
|
|
ShowWithSubst : (Show (env n), forall n. Show (tm n)) =>
|
|
Show (WithSubst tm env n)
|
|
ShowWithSubst = deriveShow
|