rhi/quox
rhi/quox
1
0
Fork 0
Code Issues 15 Pull requests 1 Releases Wiki Activity

new representation for scopes

Browse source
This commit is contained in:
rhiannon morris 2023-02-22 07:40:19 +01:00
parent c75f1514ba
commit 0e481a8098
14 changed files with 376 additions and 364 deletions
Download patch file Download diff file Expand all files Collapse all files

39
lib/Quox/Equal.idr
View file

@ -83,15 +83,15 @@ parameters (defs : Definitions' q g)
isSubSing ty =
let Element ty nc = whnf defs ty in
case ty of
TYPE _ => False
Pi {res, _} => isSubSing res.term
Lam {} => False
Sig {fst, snd, _} => isSubSing fst && isSubSing snd.term
Pair {} => False
Eq {} => True
DLam {} => False
E (s :# _) => isSubSing s
E _ => False
TYPE _ => False
Pi {res, _} => isSubSing res.term
Lam {} => False
Sig {fst, snd} => isSubSing fst && isSubSing snd.term
Pair {} => False
Eq {} => True
DLam {} => False
E (s :# _) => isSubSing s
E _ => False
parameters {auto _ : HasErr q m}
@ -141,13 +141,13 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, Eq q)}
-- Γ, x : A ⊢ s = t : B
-- -----------------------------------------
-- Γ ⊢ (λx ⇒ s) = (λx ⇒ t) : (π·x : A) → B
(Lam _ b1, Lam _ b2) => compare0 ctx' res.term b1.term b2.term
(Lam b1, Lam b2) => compare0 ctx' res.term b1.term b2.term
-- Γ, x : A ⊢ s = e x : B
-- ----------------------------------
-- Γ ⊢ (λx ⇒ s) = e : (π·x : A) → B
(E e, Lam _ b) => eta e b
(Lam _ b, E e) => eta e b
(E e, Lam b) => eta e b
(Lam b, E e) => eta e b
(E e, E f) => Elim.compare0 ctx e f
_ => throwError $ WrongType ty s t
@ -156,8 +156,8 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, Eq q)}
ctx' = ctx :< arg
eta : Elim q 0 n -> ScopeTerm q 0 n -> m ()
eta e (TUsed b) = compare0 ctx' res.term (toLamBody e) b
eta e (TUnused _) = clashT ty s t
eta e (S _ (Y b)) = compare0 ctx' res.term (toLamBody e) b
eta e (S _ (N _)) = clashT ty s t
compare0' ctx ty@(Sig {fst, snd, _}) s t = local {mode := Equal} $
case (s, t) of
@ -322,8 +322,8 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, Eq q)}
Term.compare0 ctx arg s t
compare0' _ e@(_ :@ _) f _ _ = clashE e f
compare0' ctx (CasePair epi e _ eret _ _ ebody)
(CasePair fpi f _ fret _ _ fbody) ne nf =
compare0' ctx (CasePair epi e eret ebody)
(CasePair fpi f fret fbody) ne nf =
local {mode := Equal} $ do
compare0 ctx e f
ety <- computeElimType ctx e (noOr1 ne)
@ -334,7 +334,12 @@ parameters (defs : Definitions' q _) {auto _ : (CanEqual q m, Eq q)}
unless (epi == fpi) $ throwError $ ClashQ epi fpi
compare0' _ e@(CasePair {}) f _ _ = clashE e f
compare0' ctx (s :# a) (t :# _) _ _ = Term.compare0 ctx a s t
compare0' ctx (s :# a) (t :# b) _ _ =
Term.compare0 ctx !(bigger a b) s t
where
bigger : forall a. a -> a -> m a
bigger l r = asks mode <&> \case Super => l; _ => r
compare0' ctx (s :# a) f _ _ = Term.compare0 ctx a s (E f)
compare0' ctx e (t :# b) _ _ = Term.compare0 ctx b (E e) t
compare0' _ e@(_ :# _) f _ _ = clashE e f

4
lib/Quox/Name.idr
View file

@ -45,6 +45,10 @@ export
FromString Name where
fromString x = MakeName [<] (fromString x)
public export %inline
unq : BaseName -> Name
unq = MakeName [<]
export
toDots : Name -> String

16
lib/Quox/Pretty.idr
View file

@ -40,8 +40,8 @@ data HL
public export
data PPrec
= Outer
| Ann -- right of "::"
| AnnL -- left of "::"
| Ann -- right of "∷"
| AnnL -- left of "∷"
| Eq -- "_ ≡ _ : _"
| InEq -- arguments of ≡
-- ...
@ -153,12 +153,12 @@ withPrec d = local {prec := d}
public export data BinderSort = T | D
export %inline
unders : HasEnv m => BinderSort -> List Name -> m a -> m a
unders T xs = local {prec := Outer, tnames $= (xs ++)}
unders D xs = local {prec := Outer, dnames $= (xs ++)}
unders : HasEnv m => BinderSort -> List BaseName -> m a -> m a
unders T xs = local {prec := Outer, tnames $= (map unq xs ++)}
unders D xs = local {prec := Outer, dnames $= (map unq xs ++)}
export %inline
under : HasEnv m => BinderSort -> Name -> m a -> m a
under : HasEnv m => BinderSort -> BaseName -> m a -> m a
under t x = unders t [x]
@ -237,9 +237,9 @@ a </> b = cat [a, b]
||| wrapper for names that pretty-prints highlighted as a `TVar`.
public export data TVarName = TV Name
public export data TVarName = TV BaseName
export %inline PrettyHL TVarName where prettyM (TV x) = hlF TVar $ prettyM x
||| wrapper for names that pretty-prints highlighted as a `DVar`.
public export data DVarName = DV Name
public export data DVarName = DV BaseName
export %inline PrettyHL DVarName where prettyM (DV x) = hlF DVar $ prettyM x

30
lib/Quox/Reduce.idr
View file

@ -63,18 +63,18 @@ mutual
PushSubsts Term Reduce.isCloT where
pushSubstsWith th ph (TYPE l) =
nclo $ TYPE l
pushSubstsWith th ph (Pi qty x a body) =
nclo $ Pi qty x (a // th // ph) (body // th // ph)
pushSubstsWith th ph (Lam x body) =
nclo $ Lam x $ body // th // ph
pushSubstsWith th ph (Sig x a b) =
nclo $ Sig x (a // th // ph) (b // th // ph)
pushSubstsWith th ph (Pi qty a body) =
nclo $ Pi qty (a // th // ph) (body // th // ph)
pushSubstsWith th ph (Lam body) =
nclo $ Lam (body // th // ph)
pushSubstsWith th ph (Sig a b) =
nclo $ Sig (a // th // ph) (b // th // ph)
pushSubstsWith th ph (Pair s t) =
nclo $ Pair (s // th // ph) (t // th // ph)
pushSubstsWith th ph (Eq i ty l r) =
nclo $ Eq i (ty // th // ph) (l // th // ph) (r // th // ph)
pushSubstsWith th ph (DLam i body) =
nclo $ DLam i $ body // th // ph
pushSubstsWith th ph (Eq ty l r) =
nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph)
pushSubstsWith th ph (DLam body) =
nclo $ DLam (body // th // ph)
pushSubstsWith th ph (E e) =
let Element e nc = pushSubstsWith th ph e in nclo $ E e
pushSubstsWith th ph (CloT s ps) =
@ -93,8 +93,8 @@ mutual
Right no => Element res no
pushSubstsWith th ph (f :@ s) =
nclo $ (f // th // ph) :@ (s // th // ph)
pushSubstsWith th ph (CasePair pi p x r y z b) =
nclo $ CasePair pi (p // th // ph) x (r // th // ph) y z (b // th // ph)
pushSubstsWith th ph (CasePair pi p r b) =
nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph)
pushSubstsWith th ph (f :% d) =
nclo $ (f // th // ph) :% (d // th)
pushSubstsWith th ph (s :# a) =
@ -197,13 +197,13 @@ mutual
let Element f fnf = whnf defs f in
case nchoose $ isLamHead f of
Left _ =>
let Lam {body, _} :# Pi {arg, res, _} = f
let Lam body :# Pi {arg, res, _} = f
s = s :# arg
in
whnf defs $ sub1 body s :# sub1 res s
Right nlh => Element (f :@ s) $ fnf `orNo` nlh
whnf defs (CasePair pi pair r ret x y body) =
whnf defs (CasePair pi pair ret body) =
let Element pair pairnf = whnf defs pair in
case nchoose $ isPairHead pair of
Left _ =>
@ -219,7 +219,7 @@ mutual
let Element f fnf = whnf defs f in
case nchoose $ isDLamHead f of
Left _ =>
let DLam {body, _} :# Eq {ty, l, r, _} = f
let DLam body :# Eq {ty = ty, l, r, _} = f
body = endsOr l r (dsub1 body p) p
in
whnf defs $ body :# dsub1 ty p

66
lib/Quox/Syntax/Term/Base.idr
View file

@ -47,22 +47,20 @@ mutual
TYPE : (l : Universe) -> Term q d n
||| function type
Pi : (qty : q) -> (x : Name) ->
(arg : Term q d n) -> (res : ScopeTerm q d n) -> Term q d n
Pi : (qty : q) -> (arg : Term q d n) ->
(res : ScopeTerm q d n) -> Term q d n
||| function term
Lam : (x : Name) -> (body : ScopeTerm q d n) -> Term q d n
Lam : (body : ScopeTerm q d n) -> Term q d n
||| pair type
Sig : (x : Name) -> (fst : Term q d n) -> (snd : ScopeTerm q d n) ->
Term q d n
Sig : (fst : Term q d n) -> (snd : ScopeTerm q d n) -> Term q d n
||| pair value
Pair : (fst, snd : Term q d n) -> Term q d n
||| equality type
Eq : (i : Name) -> (ty : DScopeTerm q d n) -> (l, r : Term q d n) ->
Term q d n
Eq : (ty : DScopeTerm q d n) -> (l, r : Term q d n) -> Term q d n
||| equality term
DLam : (i : Name) -> (body : DScopeTerm q d n) -> Term q d n
DLam : (body : DScopeTerm q d n) -> Term q d n
||| elimination
E : (e : Elim q d n) -> Term q d n
@ -87,11 +85,11 @@ mutual
||| pair destruction
|||
||| `CasePair 𝜋 𝑒 𝑟 𝐴 𝑥 𝑦 𝑡` is
||| `CasePair 𝜋 𝑒 ([𝑟], 𝐴) ([𝑥, 𝑦], 𝑡)` is
||| `𝐜𝐚𝐬𝐞 𝜋 · 𝑒 𝐫𝐞𝐭𝐮𝐫𝐧 𝑟 ⇒ 𝐴 𝐨𝐟 { (𝑥, 𝑦) ⇒ 𝑡 }`
CasePair : (qty : q) -> (pair : Elim q d n) ->
(r : Name) -> (ret : ScopeTerm q d n) ->
(x, y : Name) -> (body : ScopeTermN 2 q d n) ->
(ret : ScopeTerm q d n) ->
(body : ScopeTermN 2 q d n) ->
Elim q d n
||| dim application
@ -107,49 +105,51 @@ mutual
DCloE : (el : Elim q dfrom n) -> (th : Lazy (DSubst dfrom dto)) ->
Elim q dto n
||| a scope with some more bound term variables
public export
data ScopeTermN : Nat -> TermLike where
||| at least some variables are used
TUsed : (body : Term q d (s + n)) -> ScopeTermN s q d n
||| all variables are unused
TUnused : (body : Term q d n) -> ScopeTermN s q d n
0 CaseEnumArms : TermLike
CaseEnumArms q d n = SortedMap TagVal (Term q d n)
||| a scoped term with names
public export
record Scoped (s : Nat) (f : Nat -> Type) (n : Nat) where
constructor S
names : Vect s BaseName
body : ScopedBody s f n
public export
0 ScopeTerm : TermLike
ScopeTerm = ScopeTermN 1
||| a scope with some more bound dimension variable
public export
data DScopeTermN : Nat -> TermLike where
||| at least some variables are used
DUsed : (body : Term q (s + d) n) -> DScopeTermN s q d n
||| all variables are unused
DUnused : (body : Term q d n) -> DScopeTermN s q d n
data ScopedBody : Nat -> (Nat -> Type) -> Nat -> Type where
Y : (body : f (s + n)) -> ScopedBody s f n
N : (body : f n) -> ScopedBody s f n
public export
0 DScopeTerm : TermLike
0 ScopeTermN, DScopeTermN : Nat -> TermLike
ScopeTermN s q d n = Scoped s (Term q d) n
DScopeTermN s q d n = Scoped s (\d => Term q d n) d
public export
0 ScopeTerm, DScopeTerm : TermLike
ScopeTerm = ScopeTermN 1
DScopeTerm = DScopeTermN 1
%name Term s, t, r
%name Elim e, f
%name ScopeTermN body
%name DScopeTermN body
%name Scoped body
%name ScopedBody body
||| non dependent function type
public export %inline
Arr : (qty : q) -> (arg, res : Term q d n) -> Term q d n
Arr {qty, arg, res} = Pi {qty, x = "_", arg, res = TUnused res}
Arr {qty, arg, res} = Pi {qty, arg, res = S ["_"] $ N res}
||| non dependent equality type
public export %inline
Eq0 : (ty, l, r : Term q d n) -> Term q d n
Eq0 {ty, l, r} = Eq {i = "_", ty = DUnused ty, l, r}
Eq0 {ty, l, r} = Eq {ty = S ["_"] $ N ty, l, r}
||| non dependent pair type
public export %inline
And : (fst, snd : Term q d n) -> Term q d n
And {fst, snd} = Sig {x = "_", fst, snd = TUnused snd}
And {fst, snd} = Sig {fst, snd = S ["_"] $ N snd}
||| same as `F` but as a term
public export %inline

131
lib/Quox/Syntax/Term/Pretty.idr
View file

@ -32,25 +32,80 @@ ofD = hl Syntax "of"
returnD = hl Syntax "return"
export covering
prettyBindType : Pretty.HasEnv m =>
PrettyHL q => PrettyHL a => PrettyHL b =>
List q -> BaseName -> a -> Doc HL -> b -> m (Doc HL)
prettyBindType qtys x s arr t =
parensIfM Outer $ hang 2 $
parens !(prettyQtyBinds qtys $ TV x) <++> arr
<//> !(under T x $ prettyM t)
export covering
prettyLams : Pretty.HasEnv m => PrettyHL a =>
BinderSort -> List BaseName -> a -> m (Doc HL)
prettyLams sort names body = do
lam <- case sort of T => lamD; D => dlamD
header <- sequence $ [hl TVar <$> prettyM x | x <- names] ++ [darrowD]
body <- unders sort names $ prettyM body
parensIfM Outer $ sep (lam :: header) <//> body
export covering
prettyApps : Pretty.HasEnv m => PrettyHL f => PrettyHL a =>
f -> List a -> m (Doc HL)
prettyApps fun args =
parensIfM App =<< withPrec Arg
[|prettyM fun <//> (align . sep <$> traverse prettyM args)|]
export covering
prettyTuple : Pretty.HasEnv m => PrettyHL a => List a -> m (Doc HL)
prettyTuple = map (parens . align . separate commaD) . traverse prettyM
export covering
prettyArm : Pretty.HasEnv m => PrettyHL a =>
(List BaseName, Doc HL, a) -> m (Doc HL)
prettyArm (xs, pat, body) =
pure $ hang 2 $ sep
[hsep [pat, !darrowD],
!(withPrec Outer $ unders T xs $ prettyM body)]
export covering
prettyArms : Pretty.HasEnv m => PrettyHL a =>
List (List BaseName, Doc HL, a) -> m (Doc HL)
prettyArms = map (braces . align . sep) . traverse prettyArm
export covering
prettyCase : Pretty.HasEnv m =>
PrettyHL q => PrettyHL a => PrettyHL b => PrettyHL c =>
q -> a -> BaseName -> b -> List (List BaseName, Doc HL, c) ->
m (Doc HL)
prettyCase pi elim r ret arms =
pure $ align $ sep $
[hsep [caseD, !(prettyQtyBinds [pi] elim)],
hsep [returnD, !(prettyM r), !darrowD, !(under T r $ prettyM ret)],
hsep [ofD, !(prettyArms arms)]]
mutual
export covering
PrettyHL q => PrettyHL (Term q d n) where
prettyM (TYPE l) =
parensIfM App $ typeD <//> !(withPrec Arg $ prettyM l)
prettyM (Pi qty x s t) =
prettyM (Pi qty s (S [x] t)) =
prettyBindType [qty] x s !arrowD t
prettyM (Lam x t) =
let GotLams {names, body, _} = getLams' [x] t.term Refl in
prettyM (Lam (S x t)) =
let GotLams {names, body, _} = getLams' x t.term Refl in
prettyLams T (toList names) body
prettyM (Sig x s t) =
prettyBindType [] x s !timesD t
prettyM (Sig s (S [x] t)) =
prettyBindType {q} [] x s !timesD t
prettyM (Pair s t) =
let GotPairs {init, last, _} = getPairs t in
prettyTuple $ s :: init ++ [last]
prettyM (Eq _ (DUnused ty) l r) =
prettyM (Eq (S _ (N ty)) l r) =
parensIfM Eq !(withPrec InEq $ pure $
sep [!(prettyM l) <++> !eqndD, !(prettyM r) <++> colonD, !(prettyM ty)])
prettyM (Eq i (DUsed ty) l r) =
sep [!(prettyM l) <++> !eqndD,
!(prettyM r) <++> colonD, !(prettyM ty)])
prettyM (Eq (S [i] (Y ty)) l r) =
parensIfM App $
eqD <++>
sep [bracks !(withPrec Outer $ pure $ hang 2 $
@ -58,8 +113,8 @@ mutual
!(under D i $ prettyM ty)]),
!(withPrec Arg $ prettyM l),
!(withPrec Arg $ prettyM r)]
prettyM (DLam i t) =
let GotDLams {names, body, _} = getDLams' [i] t.term Refl in
prettyM (DLam (S i t)) =
let GotDLams {names, body, _} = getDLams' i t.term Refl in
prettyLams D (toList names) body
prettyM (E e) = bracks <$> prettyM e
prettyM (CloT s th) =
@ -78,7 +133,7 @@ mutual
prettyM (e :@ s) =
let GotArgs {fun, args, _} = getArgs' e [s] in
prettyApps fun args
prettyM (CasePair pi p r ret x y body) = do
prettyM (CasePair pi p (S [r] ret) (S [x, y] body)) = do
pat <- (parens . separate commaD . map (hl TVar)) <$>
traverse prettyM [x, y]
prettyCase pi p r ret [([x, y], pat, body)]
@ -97,62 +152,10 @@ mutual
[|withPrec SApp (prettyM e) </> prettyDSubst th|]
export covering
{s : Nat} -> PrettyHL q => PrettyHL (ScopeTermN s q d n) where
{s : Nat} -> PrettyHL q => PrettyHL (ScopedBody s (Term q d) n) where
prettyM body = prettyM body.term
export covering
prettyTSubst : Pretty.HasEnv m => PrettyHL q =>
TSubst q d from to -> m (Doc HL)
prettyTSubst s = prettySubstM prettyM (!ask).tnames TVar "[" "]" s
export covering
prettyBindType : Pretty.HasEnv m => PrettyHL q =>
List q -> Name -> Term q d n -> Doc HL ->
ScopeTerm q d n -> m (Doc HL)
prettyBindType qtys x s arr t =
parensIfM Outer $ hang 2 $
parens !(prettyQtyBinds qtys $ TV x) <++> arr
<//> !(under T x $ prettyM t)
export covering
prettyLams : Pretty.HasEnv m => PrettyHL q =>
BinderSort -> List Name -> Term q _ _ -> m (Doc HL)
prettyLams sort names body = do
lam <- case sort of T => lamD; D => dlamD
header <- sequence $ [hl TVar <$> prettyM x | x <- names] ++ [darrowD]
body <- unders sort names $ prettyM body
parensIfM Outer $ sep (lam :: header) <//> body
export covering
prettyApps : Pretty.HasEnv m => PrettyHL f => PrettyHL a =>
f -> List a -> m (Doc HL)
prettyApps fun args =
parensIfM App =<< withPrec Arg
[|prettyM fun <//> (align . sep <$> traverse prettyM args)|]
export covering
prettyTuple : Pretty.HasEnv m => PrettyHL a => List a -> m (Doc HL)
prettyTuple = map (parens . align . separate commaD) . traverse prettyM
export covering
prettyArm : Pretty.HasEnv m => PrettyHL a =>
(List Name, Doc HL, a) -> m (Doc HL)
prettyArm (xs, pat, body) =
pure $ hang 2 $ sep
[hsep [pat, !darrowD],
!(withPrec Outer $ unders T xs $ prettyM body)]
export covering
prettyArms : Pretty.HasEnv m => PrettyHL a =>
List (List Name, Doc HL, a) -> m (Doc HL)
prettyArms = map (braces . align . sep) . traverse prettyArm
export covering
prettyCase : Pretty.HasEnv m =>
PrettyHL q => PrettyHL a => PrettyHL b => PrettyHL c =>
q -> a -> Name -> b -> List (List Name, Doc HL, c) -> m (Doc HL)
prettyCase pi elim r ret arms =
pure $ align $ sep $
[hsep [caseD, !(prettyQtyBinds [pi] elim)],
hsep [returnD, !(prettyM r), !darrowD, !(under T r $ prettyM ret)],
hsep [ofD, !(prettyArms arms)]]

36
lib/Quox/Syntax/Term/Split.idr
View file

@ -11,8 +11,8 @@ import public Data.Vect
public export %inline
isLam : Term {} -> Bool
isLam (Lam {}) = True
isLam _ = False
isLam (Lam _) = True
isLam _ = False
public export
0 NotLam : Pred $ Term {}
@ -21,8 +21,8 @@ NotLam = No . isLam
public export %inline
isDLam : Term {} -> Bool
isDLam (DLam {}) = True
isDLam _ = False
isDLam (DLam _) = True
isDLam _ = False
public export
0 NotDLam : Pred $ Term {}
@ -113,25 +113,25 @@ getDArgs e = getDArgs' e []
infixr 1 :\\
public export
absN : Vect m Name -> Term q d (m + n) -> Term q d n
absN : Vect m BaseName -> Term q d (m + n) -> Term q d n
absN {m = 0} [] s = s
absN {m = S m} (x :: xs) s = Lam x $ TUsed $ absN xs $
rewrite sym $ plusSuccRightSucc m n in s
absN {m = S m} (x :: xs) s =
Lam $ S [x] $ Y $ absN xs $ rewrite sym $ plusSuccRightSucc m n in s
public export %inline
(:\\) : Vect m Name -> Term q d (m + n) -> Term q d n
(:\\) : Vect m BaseName -> Term q d (m + n) -> Term q d n
(:\\) = absN
infixr 1 :\\%
public export
dabsN : Vect m Name -> Term q (m + d) n -> Term q d n
dabsN : Vect m BaseName -> Term q (m + d) n -> Term q d n
dabsN {m = 0} [] s = s
dabsN {m = S m} (x :: xs) s = DLam x $ DUsed $ dabsN xs $
rewrite sym $ plusSuccRightSucc m d in s
dabsN {m = S m} (x :: xs) s =
DLam $ S [x] $ Y $ dabsN xs $ rewrite sym $ plusSuccRightSucc m d in s
public export %inline
(:\\%) : Vect m Name -> Term q (m + d) n -> Term q d n
(:\\%) : Vect m BaseName -> Term q (m + d) n -> Term q d n
(:\\%) = dabsN
@ -139,17 +139,17 @@ public export
record GetLams q d n where
constructor GotLams
{0 lams, rest : Nat}
names : Vect lams Name
names : Vect lams BaseName
body : Term q d rest
0 eq : lams + n = rest
0 notLam : NotLam body
export
getLams' : forall lams, rest.
Vect lams Name -> Term q d rest -> (0 eq : lams + n = rest) ->
Vect lams BaseName -> Term q d rest -> (0 eq : lams + n = rest) ->
GetLams q d n
getLams' xs s Refl = case nchoose $ isLam s of
Left y => let Lam x body = s in
Left y => let Lam (S [x] body) = s in
getLams' (x :: xs) (assert_smaller s body.term) Refl
Right n => GotLams xs s Refl n
@ -162,17 +162,17 @@ public export
record GetDLams q d n where
constructor GotDLams
{0 lams, rest : Nat}
names : Vect lams Name
names : Vect lams BaseName
body : Term q rest n
0 eq : lams + d = rest
0 notDLam : NotDLam body
export
getDLams' : forall lams, rest.
Vect lams Name -> Term q rest n -> (0 eq : lams + d = rest) ->
Vect lams BaseName -> Term q rest n -> (0 eq : lams + d = rest) ->
GetDLams q d n
getDLams' is s Refl = case nchoose $ isDLam s of
Left y => let DLam i body = s in
Left y => let DLam (S [i] body) = s in
getDLams' (i :: is) (assert_smaller s body.term) Refl
Right n => GotDLams is s Refl n

143
lib/Quox/Syntax/Term/Subst.idr
View file

@ -10,49 +10,53 @@ namespace CanDSubst
interface CanDSubst (0 tm : Nat -> Nat -> Type) where
(//) : tm dfrom n -> Lazy (DSubst dfrom dto) -> tm dto n
mutual
||| 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 dim-closure
||| - otherwise, wraps in a new closure
export
CanDSubst (Term q) where
s // Shift SZ = s
TYPE l // _ = TYPE l
DCloT s ph // th = DCloT s $ ph . th
s // th = DCloT s 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 dim-closure
||| - otherwise, wraps in a new closure
export
CanDSubst (Term q) where
s // Shift SZ = s
TYPE l // _ = TYPE l
DCloT s ph // th = DCloT s $ ph . th
s // th = DCloT s th
private
subDArgs : Elim q dfrom n -> DSubst dfrom dto -> Elim q dto n
subDArgs (f :% d) th = subDArgs f th :% (d // th)
subDArgs e th = DCloE e th
private
subDArgs : Elim q dfrom n -> DSubst dfrom dto -> Elim q dto n
subDArgs (f :% d) th = subDArgs f th :% (d // th)
subDArgs e th = DCloE e th
||| does the minimal reasonable work:
||| - deletes the closure around a term variable
||| - deletes an identity substitution
||| - composes (lazily) with an existing top-level dim-closure
||| - immediately looks up bound variables in a
||| top-level sequence of dimension applications
||| - otherwise, wraps in a new closure
export
CanDSubst (Elim q) where
e // Shift SZ = e
F x // _ = F x
B i // _ = B i
f :% d // th = subDArgs (f :% d) th
DCloE e ph // th = DCloE e $ ph . th
e // th = DCloE e th
||| does the minimal reasonable work:
||| - deletes the closure around a term variable
||| - deletes an identity substitution
||| - composes (lazily) with an existing top-level dim-closure
||| - immediately looks up bound variables in a
||| top-level sequence of dimension applications
||| - otherwise, wraps in a new closure
export
CanDSubst (Elim q) where
e // Shift SZ = e
F x // _ = F x
B i // _ = B i
f :% d // th = subDArgs (f :% d) th
DCloE e ph // th = DCloE e $ ph . th
e // th = DCloE e th
export
CanDSubst (ScopeTermN s q) where
TUsed body // th = TUsed $ body // th
TUnused body // th = TUnused $ body // th
namespace DSubst.ScopeTermN
export %inline
(//) : ScopeTermN s q dfrom n -> Lazy (DSubst dfrom dto) ->
ScopeTermN s q dto n
S ns (Y body) // th = S ns $ Y $ body // th
S ns (N body) // th = S ns $ N $ body // th
export
{s : Nat} -> CanDSubst (DScopeTermN s q) where
DUsed body // th = DUsed $ body // pushN s th
DUnused body // th = DUnused $ body // th
namespace DSubst.DScopeTermN
export %inline
(//) : {s : Nat} ->
DScopeTermN s q dfrom n -> Lazy (DSubst dfrom dto) ->
DScopeTermN s q dto n
S ns (Y body) // th = S ns $ Y $ body // pushN s th
S ns (N body) // th = S ns $ N $ body // th
export %inline FromVar (Elim q d) where fromVar = B
@ -94,15 +98,21 @@ CanTSubst Term where
Shift SZ => s
th => CloT s th
export %inline
{s : Nat} -> CanTSubst (ScopeTermN s) where
TUsed body // th = TUsed $ body // pushN s th
TUnused body // th = TUnused $ body // th
namespace ScopeTermN
export %inline
(//) : {s : Nat} ->
ScopeTermN s q d from -> Lazy (TSubst q d from to) ->
ScopeTermN s q d to
S ns (Y body) // th = S ns $ Y $ body // pushN s th
S ns (N body) // th = S ns $ N $ body // th
export %inline
{s : Nat} -> CanTSubst (DScopeTermN s) where
DUsed body // th = DUsed $ body // map (// shift s) th
DUnused body // th = DUnused $ body // th
namespace DScopeTermN
export %inline
(//) : {s : Nat} ->
DScopeTermN s q d from -> Lazy (TSubst q d from to) ->
DScopeTermN s q d to
S ns (Y body) // th = S ns $ Y $ body // map (// shift s) th
S ns (N body) // th = S ns $ N $ body // th
export %inline CanShift (Term q d) where s // by = s // Shift by
export %inline CanShift (Elim q d) where e // by = e // Shift by
@ -136,23 +146,34 @@ weakE : {default 1 by : Nat} -> Elim q d n -> Elim q d (by + n)
weakE t = t // shift by
namespace ScopeTermN
export %inline
(.term) : {s : Nat} -> ScopeTermN s q d n -> Term q d (s + n)
(TUsed body).term = body
(TUnused body).term = weakT body {by = s}
parameters {s : Nat}
namespace ScopeTermBody
export %inline
(.term) : ScopedBody s (Term q d) n -> Term q d (s + n)
(Y b).term = b
(N b).term = weakT b {by = s}
namespace DScopeTermN
export %inline
(.term) : {s : Nat} -> DScopeTermN s q d n -> Term q (s + d) n
(DUsed body).term = body
(DUnused body).term = dweakT body {by = s}
namespace ScopeTermN
export %inline
(.term) : ScopeTermN s q d n -> Term q d (s + n)
t.term = t.body.term
namespace DScopeTermBody
export %inline
(.term) : ScopedBody s (\d => Term q d n) d -> Term q (s + d) n
(Y b).term = b
(N b).term = dweakT b {by = s}
namespace DScopeTermN
export %inline
(.term) : DScopeTermN s q d n -> Term q (s + d) n
t.term = t.body.term
export %inline
subN : ScopeTermN s q d n -> Vect s (Elim q d n) -> Term q d n
subN (TUsed body) es = body // fromVect es
subN (TUnused body) _ = body
subN (S _ (Y body)) es = body // fromVect es
subN (S _ (N body)) _ = body
export %inline
sub1 : ScopeTerm q d n -> Elim q d n -> Term q d n
@ -160,8 +181,8 @@ sub1 t e = subN t [e]
export %inline
dsubN : DScopeTermN s q d n -> Vect s (Dim d) -> Term q d n
dsubN (DUsed body) ps = body // fromVect ps
dsubN (DUnused body) _ = body
dsubN (S _ (Y body)) ps = body // fromVect ps
dsubN (S _ (N body)) _ = body
export %inline
dsub1 : DScopeTerm q d n -> Dim d -> Term q d n

60
lib/Quox/Typechecker.idr
View file

@ -28,29 +28,9 @@ popQ pi = popQs [< pi]
private %inline
weakI : IsQty q => InferResult' q d n -> InferResult' q d (S n)
weakI = {type $= weakT, qout $= (:< zero)}
private
lookupBound : IsQty q => q -> Var n -> TContext q d n -> InferResult' q d n
lookupBound pi VZ (ctx :< ty) =
InfRes {type = weakT ty, qout = (zero <$ ctx) :< pi}
lookupBound pi (VS i) (ctx :< _) =
weakI $ lookupBound pi i ctx
private %inline
lookupFree : CanTC' q g m => Name -> m (Definition' q g)
lookupFree x = lookupFree' !ask x
parameters {auto _ : IsQty q} {auto _ : CanTC q m}
mutual
-- [todo] it seems like the options here for dealing with substitutions are
-- to either push them or parametrise the whole typechecker over ambient
-- substitutions. both of them seem like the same amount of work for the
-- computer but pushing is less work for the me
||| "Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ"
|||
||| `check ctx sg subj ty` checks that in the context `ctx`, the term
@ -116,19 +96,19 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m}
unless (k < l) $ throwError $ BadUniverse k l
pure $ zeroFor ctx
check' ctx sg (Pi qty _ arg res) ty = do
check' ctx sg (Pi qty arg res) ty = do
l <- expectTYPE !ask ty
expectEqualQ zero sg.fst
-- if Ψ | Γ ⊢₀ A ⇐ Type ℓ
check0 ctx arg (TYPE l)
-- if Ψ | Γ, x : A ⊢₀ B ⇐ Type ℓ
case res of
TUsed res => check0 (extendTy arg ctx) res (TYPE l)
TUnused res => check0 ctx res (TYPE l)
case res.body of
Y res => check0 (extendTy arg ctx) res (TYPE l)
N res => check0 ctx res (TYPE l)
-- then Ψ | Γ ⊢₀ (π·x : A) → B ⇐ Type ℓ
pure $ zeroFor ctx
check' ctx sg (Lam _ body) ty = do
check' ctx sg (Lam body) ty = do
(qty, arg, res) <- expectPi !ask ty
-- if Ψ | Γ, x : A ⊢ σ · t ⇐ B ⊳ Σ, ρ·x
-- with ρ ≤ σπ
@ -137,15 +117,15 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m}
-- then Ψ | Γ ⊢ σ · (λx ⇒ t) ⇐ (π·x : A) → B ⊳ Σ
popQ qty' qout
check' ctx sg (Sig _ fst snd) ty = do
check' ctx sg (Sig fst snd) ty = do
l <- expectTYPE !ask ty
expectEqualQ zero sg.fst
-- if Ψ | Γ ⊢₀ A ⇐ Type ℓ
check0 ctx fst (TYPE l)
-- if Ψ | Γ, x : A ⊢₀ B ⇐ Type ℓ
case snd of
TUsed snd => check0 (extendTy fst ctx) snd (TYPE l)
TUnused snd => check0 ctx snd (TYPE l)
case snd.body of
Y snd => check0 (extendTy fst ctx) snd (TYPE l)
N snd => check0 ctx snd (TYPE l)
-- then Ψ | Γ ⊢₀ (x : A) × B ⇐ Type ℓ
pure $ zeroFor ctx
@ -159,13 +139,13 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m}
-- then Ψ | Γ ⊢ σ · (s, t) ⇐ (x : A) × B ⊳ Σ₁ + Σ₂
pure $ qfst + qsnd
check' ctx sg (Eq _ t l r) ty = do
check' ctx sg (Eq t l r) ty = do
u <- expectTYPE !ask ty
expectEqualQ zero sg.fst
-- if Ψ, i | Γ ⊢₀ A ⇐ Type ℓ
case t of
DUsed t => check0 (extendDim ctx) t (TYPE u)
DUnused t => check0 ctx t (TYPE u)
case t.body of
Y t => check0 (extendDim ctx) t (TYPE u)
N t => check0 ctx t (TYPE u)
-- if Ψ | Γ ⊢₀ l ⇐ A‹0›
check0 ctx t.zero l
-- if Ψ | Γ ⊢₀ r ⇐ A‹1›
@ -173,7 +153,7 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m}
-- then Ψ | Γ ⊢₀ Eq [i ⇒ A] l r ⇐ Type ℓ
pure $ zeroFor ctx
check' ctx sg (DLam _ body) ty = do
check' ctx sg (DLam body) ty = do
(ty, l, r) <- expectEq !ask ty
-- if Ψ, i | Γ ⊢ σ · t ⇐ A ⊳ Σ
qout <- checkC (extendDim ctx) sg body.term ty.term
@ -204,11 +184,21 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m}
expectCompatQ sg.fst g.qty
-- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ 𝟎
pure $ InfRes {type = g.type.get, qout = zeroFor ctx}
where
lookupFree : Name -> m (Definition q)
lookupFree x = lookupFree' !ask x
infer' ctx sg (B i) =
-- if x : A ∈ Γ
-- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ (𝟎, σ·x, 𝟎)
pure $ lookupBound sg.fst i ctx.tctx
where
lookupBound : q -> Var n -> TContext q d n -> InferResult' q d n
lookupBound pi VZ (ctx :< ty) =
InfRes {type = weakT ty, qout = zeroFor ctx :< pi}
lookupBound pi (VS i) (ctx :< _) =
let InfRes {type, qout} = lookupBound pi i ctx in
InfRes {type = weakT type, qout = qout :< zero}
infer' ctx sg (fun :@ arg) = do
-- if Ψ | Γ ⊢ σ · f ⇒ (π·x : A) → B ⊳ Σ₁
@ -222,7 +212,7 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m}
qout = funres.qout + argout
}
infer' ctx sg (CasePair pi pair _ ret _ _ body) = do
infer' ctx sg (CasePair pi pair ret body) = do
-- if 1 ≤ π
expectCompatQ one pi
-- if Ψ | Γ ⊢ 1 · pair ⇒ (x : A) × B ⊳ Σ₁

6
lib/Quox/Typing.idr
View file

@ -40,6 +40,10 @@ namespace TContext
pushD : TContext q d n -> TContext q (S d) n
pushD tel = map (// shift 1) tel
export %inline
zeroFor : IsQty q => Context tm n -> QOutput q n
zeroFor ctx = zero <$ ctx
namespace TyContext
public export %inline
empty : {d : Nat} -> TyContext q d 0
@ -75,7 +79,7 @@ namespace QOutput
export %inline
zeroFor : TyContext q _ n -> QOutput q n
zeroFor ctx = zero <$ ctx.tctx
zeroFor ctx = zeroFor ctx.tctx
public export