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

start of equality type stuff

Browse source
This commit is contained in:
rhiannon morris 2023-01-21 02:34:28 +01:00
parent 8acc3aeadf
commit f097e1c091
13 changed files with 608 additions and 261 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

41
lib/Quox/Equal.idr
View file

@ -74,6 +74,11 @@ compareU : CanEqual' q _ m => Universe -> Universe -> m ()
compareU k l = unless !(compareU' k l) $ compareU k l = unless !(compareU' k l) $
throwError $ ClashU !mode k l throwError $ ClashU !mode k l
export %inline
compareD : HasErr q m => Dim d -> Dim d -> m ()
compareD p q = unless (p == q) $
throwError $ ClashD p q
mutual mutual
private covering private covering
compareTN' : CanEqual' q _ m => Eq q => compareTN' : CanEqual' q _ m => Eq q =>
@ -96,14 +101,25 @@ mutual
compareTN' (Pi qty1 _ arg1 res1) (Pi qty2 _ arg2 res2) _ _ = do compareTN' (Pi qty1 _ arg1 res1) (Pi qty2 _ arg2 res2) _ _ = do
unless (qty1 == qty2) $ throwError $ ClashQ qty1 qty2 unless (qty1 == qty2) $ throwError $ ClashQ qty1 qty2
compareT0 arg2 arg1 -- reversed for contravariant domain compareT0 arg2 arg1 -- reversed for contravariant domain
compareTS0 res1 res2 compareST0 res1 res2
compareTN' s@(Pi {}) t _ _ = clashT s t compareTN' s@(Pi {}) t _ _ = clashT s t
-- [todo] eta -- [todo] eta
compareTN' (Lam _ body1) (Lam _ body2) _ _ = compareTN' (Lam _ body1) (Lam _ body2) _ _ =
local {mode := Equal} $ compareTS0 body1 body2 local {mode := Equal} $ compareST0 body1 body2
compareTN' s@(Lam {}) t _ _ = clashT s t compareTN' s@(Lam {}) t _ _ = clashT s t
compareTN' (Eq _ ty1 l1 r1) (Eq _ ty2 l2 r2) _ _ = do
compareDST0 ty1 ty2
local {mode := Equal} $ do
compareT0 l1 l2
compareT0 r1 r2
compareTN' s@(Eq {}) t _ _ = clashT s t
compareTN' (DLam _ body1) (DLam _ body2) _ _ =
compareDST0 body1 body2
compareTN' s@(DLam {}) t _ _ = clashT s t
compareTN' (CloT {}) _ ps _ = void $ ps IsCloT compareTN' (CloT {}) _ ps _ = void $ ps IsCloT
compareTN' (DCloT {}) _ ps _ = void $ ps IsDCloT compareTN' (DCloT {}) _ ps _ = void $ ps IsDCloT
@ -136,6 +152,11 @@ mutual
compareT0 arg1 arg2 compareT0 arg1 arg2
compareEN' e@(_ :@ _) f _ _ = clashE e f compareEN' e@(_ :@ _) f _ _ = clashE e f
compareEN' (fun1 :% dim1) (fun2 :% dim2) _ _ = do
compareE0 fun1 fun2
compareD dim1 dim2
compareEN' e@(_ :% _) f _ _ = clashE e f
-- [todo] is always checking the types are equal correct? -- [todo] is always checking the types are equal correct?
compareEN' (tm1 :# ty1) (tm2 :# ty2) _ _ = do compareEN' (tm1 :# ty1) (tm2 :# ty2) _ _ = do
compareT0 tm1 tm2 compareT0 tm1 tm2
@ -179,12 +200,18 @@ mutual
compareE0 e f = compareEN (whnfE e) (whnfE f) compareE0 e f = compareEN (whnfE e) (whnfE f)
export covering %inline export covering %inline
compareTS0 : CanEqual' q _ m => Eq q => compareST0 : CanEqual' q _ m => Eq q =>
ScopeTerm q 0 n -> ScopeTerm q 0 n -> m () ScopeTerm q 0 n -> ScopeTerm q 0 n -> m ()
compareTS0 (TUnused body1) (TUnused body2) = compareST0 (TUnused body0) (TUnused body1) = compareT0 body0 body1
compareT0 body1 body2 compareST0 body0 body1 = compareT0 body0.term body1.term
compareTS0 body1 body2 =
compareT0 (fromScopeTerm body1) (fromScopeTerm body2) export covering %inline
compareDST0 : CanEqual' q _ m => Eq q =>
DScopeTerm q 0 n -> DScopeTerm q 0 n -> m ()
compareDST0 (DUnused body0) (DUnused body1) = compareT0 body0 body1
compareDST0 body0 body1 = do
compareT0 body0.zero body1.zero
compareT0 body0.one body1.one
private %inline private %inline

20
lib/Quox/Pretty.idr
View file

@ -42,6 +42,8 @@ data PPrec
= Outer = Outer
| Ann -- right of "::" | Ann -- right of "::"
| AnnL -- left of "::" | AnnL -- left of "::"
| Eq -- "_ ≡ _ : _"
| InEq -- arguments of ≡
-- ... -- ...
| App -- term/dimension application | App -- term/dimension application
| SApp -- substitution application | SApp -- substitution application
@ -66,9 +68,17 @@ hlF' : Functor f => HL -> f (Doc HL) -> f (Doc HL)
hlF' = map . hl' hlF' = map . hl'
export %inline
delims : Doc HL -> Doc HL -> Doc HL -> Doc HL
delims l r doc = hl Delim l <+> doc <+> hl Delim r
export %inline export %inline
parens : Doc HL -> Doc HL parens : Doc HL -> Doc HL
parens doc = hl Delim "(" <+> doc <+> hl Delim ")" parens = delims "(" ")"
export %inline
bracks : Doc HL -> Doc HL
bracks = delims "[" "]"
export %inline export %inline
parensIf : Bool -> Doc HL -> Doc HL parensIf : Bool -> Doc HL -> Doc HL
@ -125,10 +135,14 @@ withPrec d = local {prec := d}
public export data BinderSort = T | 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 ++)}
export %inline export %inline
under : HasEnv m => BinderSort -> Name -> m a -> m a under : HasEnv m => BinderSort -> Name -> m a -> m a
under T x = local {prec := Outer, tnames $= (x ::)} under t x = unders t [x]
under D x = local {prec := Outer, dnames $= (x ::)}
public export public export

8
lib/Quox/Syntax/Dim.idr
View file

@ -67,7 +67,7 @@ prettyDSubst th =
!(ifUnicode "⟨" "<") !(ifUnicode "⟩" ">") th !(ifUnicode "⟨" "<") !(ifUnicode "⟩" ">") th
export FromVar Dim where fromVar = B public export FromVar Dim where fromVar = B
export export
CanShift Dim where CanShift Dim where
@ -106,3 +106,9 @@ DecEq (Dim d) where
decEq (B i) (B j) with (decEq i j) decEq (B i) (B j) with (decEq i j)
_ | Yes prf = Yes $ cong B prf _ | Yes prf = Yes $ cong B prf
_ | No contra = No $ contra . injective _ | No contra = No $ contra . injective
||| abbreviation for a bound variable like `BV 4` instead of
||| `B (VS (VS (VS (VS VZ))))`
public export %inline
BV : (i : Nat) -> (0 _ : LT i d) => Dim d
BV i = B $ V i

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

@ -23,13 +23,15 @@ import Data.Vect
infixl 8 :# infixl 8 :#
infixl 9 :@ infixl 9 :@, :%
mutual mutual
public export public export
TSubst : Type -> Nat -> Nat -> Nat -> Type 0 TSubst : Type -> Nat -> Nat -> Nat -> Type
TSubst q d = Subst (\n => Elim q d n) TSubst q d = Subst $ Elim q d
||| first argument `d` is dimension scope size, second `n` is term scope size ||| first argument `q` is quantity type;
||| second argument `d` is dimension scope size;
||| third `n` is term scope size
public export public export
data Term : (q : Type) -> (d, n : Nat) -> Type where data Term : (q : Type) -> (d, n : Nat) -> Type where
||| type of types ||| type of types
@ -41,6 +43,12 @@ mutual
||| function term ||| function term
Lam : (x : Name) -> (body : ScopeTerm q d n) -> Term q d n Lam : (x : Name) -> (body : ScopeTerm 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
||| equality term
DLam : (i : Name) -> (body : DScopeTerm q d n) -> Term q d n
||| elimination ||| elimination
E : (e : Elim q d n) -> Term q d n E : (e : Elim q d n) -> Term q d n
@ -62,6 +70,9 @@ mutual
||| term application ||| term application
(:@) : (fun : Elim q d n) -> (arg : Term q d n) -> Elim q d n (:@) : (fun : Elim q d n) -> (arg : Term q d n) -> Elim q d n
||| dim application
(:%) : (fun : Elim q d n) -> (arg : Dim d) -> Elim q d n
||| type-annotated term ||| type-annotated term
(:#) : (tm, ty : Term q d n) -> Elim q d n (:#) : (tm, ty : Term q d n) -> Elim q d n
@ -93,10 +104,16 @@ mutual
%name ScopeTerm body %name ScopeTerm body
%name DScopeTerm body %name DScopeTerm body
||| non dependent function type
public export %inline public export %inline
Arr : (qty : q) -> (arg, res : Term q d n) -> Term q d n 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, x = "_", arg, res = TUnused 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}
||| same as `F` but as a term ||| same as `F` but as a term
public export %inline public export %inline
FT : Name -> Term q d n FT : Name -> Term q d n

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

@ -10,20 +10,18 @@ import Data.Vect
%default total %default total
parameters {auto _ : Pretty.HasEnv m} private %inline
private %inline arrowD : m (Doc HL) arrowD, lamD, eqndD, dlamD, annD : Pretty.HasEnv m => m (Doc HL)
arrowD = hlF Syntax $ ifUnicode "→" "->" arrowD = hlF Syntax $ ifUnicode "→" "->"
lamD = hlF Syntax $ ifUnicode "λ" "fun"
eqndD = hlF Syntax $ ifUnicode "≡" "=="
dlamD = hlF Syntax $ ifUnicode "λᴰ" "dfun"
annD = hlF Syntax $ ifUnicode "∷" "::"
private %inline lamD : m (Doc HL) private %inline
lamD = hlF Syntax $ ifUnicode "λ" "fun" typeD, eqD, colonD : Doc HL
typeD = hl Syntax "Type"
private %inline annD : m (Doc HL) eqD = hl Syntax "Eq"
annD = hlF Syntax $ ifUnicode "⦂" "::"
private %inline typeD : Doc HL
typeD = hl Syntax "Type"
private %inline colonD : Doc HL
colonD = hl Syntax ":" colonD = hl Syntax ":"
mutual mutual
@ -36,11 +34,23 @@ mutual
!(prettyBinder [qty] x s) <++> !arrowD !(prettyBinder [qty] x s) <++> !arrowD
<//> !(under T x $ prettyM t) <//> !(under T x $ prettyM t)
prettyM (Lam x t) = prettyM (Lam x t) =
parensIfM Outer $ let GotLams {names, body, _} = getLams' [x] t.term Refl in
sep [!lamD, hl TVar !(prettyM x), !arrowD] prettyLams T (toList names) body
<//> !(under T x $ prettyM t) prettyM (Eq _ (DUnused ty) l r) =
prettyM (E e) = parensIfM Eq !(withPrec InEq $ pure $
pure $ hl Delim "[" <+> !(prettyM e) <+> hl Delim "]" sep [!(prettyM l) <++> !eqndD, !(prettyM r) <++> colonD, !(prettyM ty)])
prettyM (Eq i (DUsed ty) l r) =
parensIfM App $
eqD <++>
sep [bracks !(withPrec Outer $ pure $ hang 2 $
sep [hl DVar !(prettyM i) <++> !arrowD,
!(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
prettyLams D (toList names) body
prettyM (E e) = bracks <$> prettyM e
prettyM (CloT s th) = prettyM (CloT s th) =
parensIfM SApp . hang 2 =<< parensIfM SApp . hang 2 =<<
[|withPrec SApp (prettyM s) </> prettyTSubst th|] [|withPrec SApp (prettyM s) </> prettyTSubst th|]
@ -55,9 +65,11 @@ mutual
prettyM (B i) = prettyM (B i) =
prettyVar TVar TVarErr (!ask).tnames i prettyVar TVar TVarErr (!ask).tnames i
prettyM (e :@ s) = prettyM (e :@ s) =
let GotArgs f args _ = getArgs' e [s] in let GotArgs {fun, args, _} = getArgs' e [s] in
parensIfM App =<< withPrec Arg prettyApps fun args
[|prettyM f <//> (align . sep <$> traverse prettyM args)|] prettyM (e :% d) =
let GotDArgs {fun, args, _} = getDArgs' e [d] in
prettyApps fun args
prettyM (s :# a) = prettyM (s :# a) =
parensIfM Ann $ hang 2 $ parensIfM Ann $ hang 2 $
!(withPrec AnnL $ prettyM s) <++> !annD !(withPrec AnnL $ prettyM s) <++> !annD
@ -71,7 +83,7 @@ mutual
export covering export covering
PrettyHL q => PrettyHL (ScopeTerm q d n) where PrettyHL q => PrettyHL (ScopeTerm q d n) where
prettyM body = prettyM $ fromScopeTerm body prettyM body = prettyM body.term
export covering export covering
prettyTSubst : Pretty.HasEnv m => PrettyHL q => prettyTSubst : Pretty.HasEnv m => PrettyHL q =>
@ -86,3 +98,19 @@ mutual
hsep [hl TVar !(prettyM x), hsep [hl TVar !(prettyM x),
sep [!(prettyQtyBinds pis), sep [!(prettyQtyBinds pis),
hsep [colonD, !(withPrec Outer $ prettyM a)]]] hsep [colonD, !(withPrec Outer $ prettyM a)]]]
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] ++ [arrowD]
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)|]

226
lib/Quox/Syntax/Term/Reduce.idr
View file

@ -12,24 +12,29 @@ mutual
NCTYPE : NotCloT $ TYPE _ NCTYPE : NotCloT $ TYPE _
NCPi : NotCloT $ Pi {} NCPi : NotCloT $ Pi {}
NCLam : NotCloT $ Lam {} NCLam : NotCloT $ Lam {}
NCEq : NotCloT $ Eq {}
NCDLam : NotCloT $ DLam {}
NCE : NotCloE e -> NotCloT $ E e NCE : NotCloE e -> NotCloT $ E e
public export public export
data NotCloE : Elim {} -> Type where data NotCloE : Elim {} -> Type where
NCF : NotCloE $ F _ NCF : NotCloE $ F _
NCB : NotCloE $ B _ NCB : NotCloE $ B _
NCApp : NotCloE $ _ :@ _ NCApp : NotCloE $ _ :@ _
NCAnn : NotCloE $ _ :# _ NCDApp : NotCloE $ _ :% _
NCAnn : NotCloE $ _ :# _
mutual mutual
export export
notCloT : (t : Term {}) -> Dec (NotCloT t) notCloT : (t : Term {}) -> Dec (NotCloT t)
notCloT (TYPE _) = Yes NCTYPE notCloT (TYPE _) = Yes NCTYPE
notCloT (Pi {}) = Yes NCPi notCloT (Pi {}) = Yes NCPi
notCloT (Lam {}) = Yes NCLam notCloT (Lam {}) = Yes NCLam
notCloT (E e) with (notCloE e) notCloT (Eq {}) = Yes NCEq
notCloT (E e) | Yes nc = Yes $ NCE nc notCloT (DLam {}) = Yes NCDLam
notCloT (E e) | No c = No $ \case NCE nc => c nc notCloT (E e) = case notCloE e of
Yes nc => Yes $ NCE nc
No c => No $ \case NCE nc => c nc
notCloT (CloT {}) = No $ \case _ impossible notCloT (CloT {}) = No $ \case _ impossible
notCloT (DCloT {}) = No $ \case _ impossible notCloT (DCloT {}) = No $ \case _ impossible
@ -38,26 +43,27 @@ mutual
notCloE (F _) = Yes NCF notCloE (F _) = Yes NCF
notCloE (B _) = Yes NCB notCloE (B _) = Yes NCB
notCloE (_ :@ _) = Yes NCApp notCloE (_ :@ _) = Yes NCApp
notCloE (_ :% _) = Yes NCDApp
notCloE (_ :# _) = Yes NCAnn notCloE (_ :# _) = Yes NCAnn
notCloE (CloE {}) = No $ \case _ impossible notCloE (CloE {}) = No $ \case _ impossible
notCloE (DCloE {}) = No $ \case _ impossible notCloE (DCloE {}) = No $ \case _ impossible
||| a term which is not a top level closure ||| a term which is not a top level closure
public export public export
NotCloTerm : Type -> Nat -> Nat -> Type NonCloTerm : Type -> Nat -> Nat -> Type
NotCloTerm q d n = Subset (Term q d n) NotCloT NonCloTerm q d n = Subset (Term q d n) NotCloT
||| an elimination which is not a top level closure ||| an elimination which is not a top level closure
public export public export
NotCloElim : Type -> Nat -> Nat -> Type NonCloElim : Type -> Nat -> Nat -> Type
NotCloElim q d n = Subset (Elim q d n) NotCloE NonCloElim q d n = Subset (Elim q d n) NotCloE
public export %inline public export %inline
ncloT : (t : Term q d n) -> (0 _ : NotCloT t) => NotCloTerm q d n ncloT : (t : Term q d n) -> (0 _ : NotCloT t) => NonCloTerm q d n
ncloT t @{p} = Element t p ncloT t @{p} = Element t p
public export %inline public export %inline
ncloE : (e : Elim q d n) -> (0 _ : NotCloE e) => NotCloElim q d n ncloE : (e : Elim q d n) -> (0 _ : NotCloE e) => NonCloElim q d n
ncloE e @{p} = Element e p ncloE e @{p} = Element e p
@ -66,34 +72,38 @@ mutual
||| if the input term has any top-level closures, push them under one layer of ||| if the input term has any top-level closures, push them under one layer of
||| syntax ||| syntax
export %inline export %inline
pushSubstsT : Term q d n -> NotCloTerm q d n pushSubstsT : Term q d n -> NonCloTerm q d n
pushSubstsT s = pushSubstsTWith id id s pushSubstsT s = pushSubstsTWith id id s
||| if the input elimination has any top-level closures, push them under one ||| if the input elimination has any top-level closures, push them under one
||| layer of syntax ||| layer of syntax
export %inline export %inline
pushSubstsE : Elim q d n -> NotCloElim q d n pushSubstsE : Elim q d n -> NonCloElim q d n
pushSubstsE e = pushSubstsEWith id id e pushSubstsE e = pushSubstsEWith id id e
export export
pushSubstsTWith : DSubst dfrom dto -> TSubst q dto from to -> pushSubstsTWith : DSubst dfrom dto -> TSubst q dto from to ->
Term q dfrom from -> NotCloTerm q dto to Term q dfrom from -> NonCloTerm q dto to
pushSubstsTWith th ph (TYPE l) = pushSubstsTWith th ph (TYPE l) =
ncloT $ TYPE l ncloT $ TYPE l
pushSubstsTWith th ph (Pi qty x a body) = pushSubstsTWith th ph (Pi qty x a body) =
ncloT $ Pi qty x (subs a th ph) (subs body th ph) ncloT $ Pi qty x (subs a th ph) (subs body th ph)
pushSubstsTWith th ph (Lam x body) = pushSubstsTWith th ph (Lam x body) =
ncloT $ Lam x $ subs body th ph ncloT $ Lam x $ subs body th ph
pushSubstsTWith th ph (Eq i ty l r) =
ncloT $ Eq i (subs ty th ph) (subs l th ph) (subs r th ph)
pushSubstsTWith th ph (DLam i body) =
ncloT $ DLam i $ subs body th ph
pushSubstsTWith th ph (E e) = pushSubstsTWith th ph (E e) =
let Element e _ = pushSubstsEWith th ph e in ncloT $ E e let Element e nc = pushSubstsEWith th ph e in ncloT $ E e
pushSubstsTWith th ph (CloT s ps) = pushSubstsTWith th ph (CloT s ps) =
pushSubstsTWith th (comp' th ps ph) s pushSubstsTWith th (comp th ps ph) s
pushSubstsTWith th ph (DCloT s ps) = pushSubstsTWith th ph (DCloT s ps) =
pushSubstsTWith (ps . th) ph s pushSubstsTWith (ps . th) ph s
export export
pushSubstsEWith : DSubst dfrom dto -> TSubst q dto from to -> pushSubstsEWith : DSubst dfrom dto -> TSubst q dto from to ->
Elim q dfrom from -> NotCloElim q dto to Elim q dfrom from -> NonCloElim q dto to
pushSubstsEWith th ph (F x) = pushSubstsEWith th ph (F x) =
ncloE $ F x ncloE $ F x
pushSubstsEWith th ph (B i) = pushSubstsEWith th ph (B i) =
@ -103,10 +113,12 @@ mutual
No _ => assert_total pushSubstsE res No _ => assert_total pushSubstsE res
pushSubstsEWith th ph (f :@ s) = pushSubstsEWith th ph (f :@ s) =
ncloE $ subs f th ph :@ subs s th ph ncloE $ subs f th ph :@ subs s th ph
pushSubstsEWith th ph (f :% d) =
ncloE $ subs f th ph :% (d // th)
pushSubstsEWith th ph (s :# a) = pushSubstsEWith th ph (s :# a) =
ncloE $ subs s th ph :# subs a th ph ncloE $ subs s th ph :# subs a th ph
pushSubstsEWith th ph (CloE e ps) = pushSubstsEWith th ph (CloE e ps) =
pushSubstsEWith th (comp' th ps ph) e pushSubstsEWith th (comp th ps ph) e
pushSubstsEWith th ph (DCloE e ps) = pushSubstsEWith th ph (DCloE e ps) =
pushSubstsEWith (ps . th) ph e pushSubstsEWith (ps . th) ph e
@ -121,57 +133,6 @@ parameters (th : DSubst dfrom dto) (ph : TSubst q dto from to)
pushSubstsEWith' e = (pushSubstsEWith th ph e).fst pushSubstsEWith' e = (pushSubstsEWith th ph e).fst
public export %inline
pushSubstsT' : Term q d n -> Term q d n
pushSubstsT' s = (pushSubstsT s).fst
public export %inline
pushSubstsE' : Elim q d n -> Elim q d n
pushSubstsE' e = (pushSubstsE e).fst
-- mutual
-- -- tightening a term/elim also causes substitutions to be pushed through.
-- -- this is because otherwise a variable in an unused part of the subst
-- -- would cause it to incorrectly fail
-- export covering
-- Tighten (Term d) where
-- tighten p (TYPE l) =
-- pure $ TYPE l
-- tighten p (Pi qty x arg res) =
-- Pi qty x <$> tighten p arg
-- <*> tighten p res
-- tighten p (Lam x body) =
-- Lam x <$> tighten p body
-- tighten p (E e) =
-- E <$> tighten p e
-- tighten p (CloT tm th) =
-- tighten p $ pushSubstsTWith' id th tm
-- tighten p (DCloT tm th) =
-- tighten p $ pushSubstsTWith' th id tm
-- export covering
-- Tighten (Elim d) where
-- tighten p (F x) =
-- pure $ F x
-- tighten p (B i) =
-- B <$> tighten p i
-- tighten p (fun :@ arg) =
-- [|tighten p fun :@ tighten p arg|]
-- tighten p (tm :# ty) =
-- [|tighten p tm :# tighten p ty|]
-- tighten p (CloE el th) =
-- tighten p $ pushSubstsEWith' id th el
-- tighten p (DCloE el th) =
-- tighten p $ pushSubstsEWith' th id el
-- export covering
-- Tighten (ScopeTerm d) where
-- tighten p (TUsed body) = TUsed <$> tighten (Keep p) body
-- tighten p (TUnused body) = TUnused <$> tighten p body
public export %inline public export %inline
weakT : Term q d n -> Term q d (S n) weakT : Term q d n -> Term q d (S n)
weakT t = t //. shift 1 weakT t = t //. shift 1
@ -189,24 +150,26 @@ mutual
IsDCloT : IsRedexT $ DCloT {} IsDCloT : IsRedexT $ DCloT {}
IsERedex : IsRedexE e -> IsRedexT $ E e IsERedex : IsRedexE e -> IsRedexT $ E e
public export %inline
NotRedexT : Term q d n -> Type
NotRedexT = Not . IsRedexT
public export public export
data IsRedexE : Elim q d n -> Type where data IsRedexE : Elim q d n -> Type where
IsUpsilonE : IsRedexE $ E _ :# _ IsUpsilonE : IsRedexE $ E _ :# _
IsBetaLam : IsRedexE $ (Lam {} :# Pi {}) :@ _ IsBetaLam : IsRedexE $ (Lam {} :# Pi {}) :@ _
IsBetaDLam : IsRedexE $ (DLam {} :# Eq {}) :% _
IsCloE : IsRedexE $ CloE {} IsCloE : IsRedexE $ CloE {}
IsDCloE : IsRedexE $ DCloE {} IsDCloE : IsRedexE $ DCloE {}
public export %inline public export %inline
NotRedexE : Elim q d n -> Type NotRedexT : Term q d n -> Type
NotRedexE = Not . IsRedexE NotRedexT = Not . IsRedexT
public export %inline
NotRedexE : Elim q d n -> Type
NotRedexE = Not . IsRedexE
mutual mutual
export %inline -- [todo] PLEASE replace these with macros omfg
export
isRedexT : (t : Term {}) -> Dec (IsRedexT t) isRedexT : (t : Term {}) -> Dec (IsRedexT t)
isRedexT (E (tm :# ty)) = Yes IsUpsilonT isRedexT (E (tm :# ty)) = Yes IsUpsilonT
isRedexT (CloT {}) = Yes IsCloT isRedexT (CloT {}) = Yes IsCloT
@ -216,16 +179,22 @@ mutual
isRedexT (E e@(_ :@ _)) with (isRedexE e) isRedexT (E e@(_ :@ _)) with (isRedexE e)
_ | Yes yes = Yes $ IsERedex yes _ | Yes yes = Yes $ IsERedex yes
_ | No no = No $ \case IsERedex p => no p _ | No no = No $ \case IsERedex p => no p
isRedexT (E e@(_ :% _)) with (isRedexE e)
_ | Yes yes = Yes $ IsERedex yes
_ | No no = No $ \case IsERedex p => no p
isRedexT (TYPE {}) = No $ \case _ impossible isRedexT (TYPE {}) = No $ \case _ impossible
isRedexT (Pi {}) = No $ \case _ impossible isRedexT (Pi {}) = No $ \case _ impossible
isRedexT (Lam {}) = No $ \case _ impossible isRedexT (Lam {}) = No $ \case _ impossible
isRedexT (Eq {}) = No $ \case _ impossible
isRedexT (DLam {}) = No $ \case _ impossible
isRedexT (E (F _)) = No $ \case IsERedex _ impossible isRedexT (E (F _)) = No $ \case IsERedex _ impossible
isRedexT (E (B _)) = No $ \case IsERedex _ impossible isRedexT (E (B _)) = No $ \case IsERedex _ impossible
export %inline export
isRedexE : (e : Elim {}) -> Dec (IsRedexE e) isRedexE : (e : Elim {}) -> Dec (IsRedexE e)
isRedexE (E _ :# _) = Yes IsUpsilonE isRedexE (E _ :# _) = Yes IsUpsilonE
isRedexE ((Lam {} :# Pi {}) :@ _) = Yes IsBetaLam isRedexE ((Lam {} :# Pi {}) :@ _) = Yes IsBetaLam
isRedexE ((DLam {} :# Eq {}) :% _) = Yes IsBetaDLam
isRedexE (CloE {}) = Yes IsCloE isRedexE (CloE {}) = Yes IsCloE
isRedexE (DCloE {}) = Yes IsDCloE isRedexE (DCloE {}) = Yes IsDCloE
isRedexE (F x) = No $ \case _ impossible isRedexE (F x) = No $ \case _ impossible
@ -233,21 +202,48 @@ mutual
isRedexE (F _ :@ _) = No $ \case _ impossible isRedexE (F _ :@ _) = No $ \case _ impossible
isRedexE (B _ :@ _) = No $ \case _ impossible isRedexE (B _ :@ _) = No $ \case _ impossible
isRedexE (_ :@ _ :@ _) = No $ \case _ impossible isRedexE (_ :@ _ :@ _) = No $ \case _ impossible
isRedexE (_ :% _ :@ _) = No $ \case _ impossible
isRedexE (CloE {} :@ _) = No $ \case _ impossible
isRedexE (DCloE {} :@ _) = No $ \case _ impossible
isRedexE ((TYPE _ :# _) :@ _) = No $ \case _ impossible isRedexE ((TYPE _ :# _) :@ _) = No $ \case _ impossible
isRedexE ((Pi {} :# _) :@ _) = No $ \case _ impossible isRedexE ((Pi {} :# _) :@ _) = No $ \case _ impossible
isRedexE ((Eq {} :# _) :@ _) = No $ \case _ impossible
isRedexE ((DLam {} :# _) :@ _) = No $ \case _ impossible
isRedexE ((Lam {} :# TYPE _) :@ _) = No $ \case _ impossible isRedexE ((Lam {} :# TYPE _) :@ _) = No $ \case _ impossible
isRedexE ((Lam {} :# Lam {}) :@ _) = No $ \case _ impossible isRedexE ((Lam {} :# Lam {}) :@ _) = No $ \case _ impossible
isRedexE ((Lam {} :# Eq {}) :@ _) = No $ \case _ impossible
isRedexE ((Lam {} :# DLam {}) :@ _) = No $ \case _ impossible
isRedexE ((Lam {} :# E _) :@ _) = No $ \case _ impossible isRedexE ((Lam {} :# E _) :@ _) = No $ \case _ impossible
isRedexE ((Lam {} :# CloT {}) :@ _) = No $ \case _ impossible isRedexE ((Lam {} :# CloT {}) :@ _) = No $ \case _ impossible
isRedexE ((Lam {} :# DCloT {}) :@ _) = No $ \case _ impossible isRedexE ((Lam {} :# DCloT {}) :@ _) = No $ \case _ impossible
isRedexE ((E _ :# _) :@ _) = No $ \case _ impossible isRedexE ((E _ :# _) :@ _) = No $ \case _ impossible
isRedexE ((CloT {} :# _) :@ _) = No $ \case _ impossible isRedexE ((CloT {} :# _) :@ _) = No $ \case _ impossible
isRedexE ((DCloT {} :# _) :@ _) = No $ \case _ impossible isRedexE ((DCloT {} :# _) :@ _) = No $ \case _ impossible
isRedexE (CloE {} :@ _) = No $ \case _ impossible isRedexE ((TYPE _ :# _) :% _) = No $ \case _ impossible
isRedexE (DCloE {} :@ _) = No $ \case _ impossible isRedexE ((Pi {} :# _) :% _) = No $ \case _ impossible
isRedexE ((Eq {} :# _) :% _) = No $ \case _ impossible
isRedexE ((Lam {} :# _) :% _) = No $ \case _ impossible
isRedexE ((DLam {} :# TYPE _) :% _) = No $ \case _ impossible
isRedexE ((DLam {} :# Pi {}) :% _) = No $ \case _ impossible
isRedexE ((DLam {} :# Lam {}) :% _) = No $ \case _ impossible
isRedexE ((DLam {} :# DLam {}) :% _) = No $ \case _ impossible
isRedexE ((DLam {} :# E _) :% _) = No $ \case _ impossible
isRedexE ((DLam {} :# CloT {}) :% _) = No $ \case _ impossible
isRedexE ((DLam {} :# DCloT {}) :% _) = No $ \case _ impossible
isRedexE ((E _ :# _) :% _) = No $ \case _ impossible
isRedexE ((CloT {} :# _) :% _) = No $ \case _ impossible
isRedexE ((DCloT {} :# _) :% _) = No $ \case _ impossible
isRedexE (F _ :% _) = No $ \case _ impossible
isRedexE (B _ :% _) = No $ \case _ impossible
isRedexE (_ :@ _ :% _) = No $ \case _ impossible
isRedexE (_ :% _ :% _) = No $ \case _ impossible
isRedexE (CloE {} :% _) = No $ \case _ impossible
isRedexE (DCloE {} :% _) = No $ \case _ impossible
isRedexE (TYPE _ :# _) = No $ \case _ impossible isRedexE (TYPE _ :# _) = No $ \case _ impossible
isRedexE (Pi {} :# _) = No $ \case _ impossible isRedexE (Pi {} :# _) = No $ \case _ impossible
isRedexE (Lam {} :# _) = No $ \case _ impossible isRedexE (Lam {} :# _) = No $ \case _ impossible
isRedexE (Eq {} :# _) = No $ \case _ impossible
isRedexE (DLam {} :# _) = No $ \case _ impossible
isRedexE (CloT {} :# _) = No $ \case _ impossible isRedexE (CloT {} :# _) = No $ \case _ impossible
isRedexE (DCloT {} :# _) = No $ \case _ impossible isRedexE (DCloT {} :# _) = No $ \case _ impossible
@ -272,8 +268,7 @@ NonRedexElim q d n = Subset (Elim q d n) NotRedexE
||| substitute a term with annotation for the bound variable of a `ScopeTerm` ||| substitute a term with annotation for the bound variable of a `ScopeTerm`
export %inline export %inline
substScope : (arg, argTy : Term q d n) -> (body : ScopeTerm q d n) -> Term q d n substScope : (arg, argTy : Term q d n) -> (body : ScopeTerm q d n) -> Term q d n
substScope arg argTy (TUsed body) = body // one (arg :# argTy) substScope arg argTy body = sub1 body (arg :# argTy)
substScope arg argTy (TUnused body) = body
mutual mutual
export %inline export %inline
@ -287,7 +282,12 @@ mutual
stepE' : (e : Elim q d n) -> IsRedexE e -> Elim q d n stepE' : (e : Elim q d n) -> IsRedexE e -> Elim q d n
stepE' (E e :# _) IsUpsilonE = e stepE' (E e :# _) IsUpsilonE = e
stepE' ((Lam {body, _} :# Pi {arg, res, _}) :@ s) IsBetaLam = stepE' ((Lam {body, _} :# Pi {arg, res, _}) :@ s) IsBetaLam =
substScope s arg body :# substScope s arg res let s = s :# arg in sub1 body s :# sub1 res s
stepE' ((DLam {body, _} :# Eq {ty, l, r, _}) :% dim) IsBetaDLam =
case dim of
K Zero => l :# ty.zero
K One => r :# ty.one
B _ => dsub1 body dim :# dsub1 ty dim
stepE' (CloE e th) IsCloE = pushSubstsEWith' id th e stepE' (CloE e th) IsCloE = pushSubstsEWith' id th e
stepE' (DCloE e th) IsDCloE = pushSubstsEWith' th id e stepE' (DCloE e th) IsDCloE = pushSubstsEWith' th id e
@ -301,12 +301,38 @@ stepE e = case isRedexE e of Yes y => Right $ stepE' e y; No n => Left n
export covering export covering
whnfT : Term q d n -> NonRedexTerm q d n whnfT : Term q d n -> NonRedexTerm q d n
whnfT s = case stepT s of whnfT s = case stepT s of Right s' => whnfT s'; Left done => Element s done
Right s' => whnfT s'
Left done => Element s done
export covering export covering
whnfE : Elim q d n -> NonRedexElim q d n whnfE : Elim q d n -> NonRedexElim q d n
whnfE e = case stepE e of whnfE e = case stepE e of Right e' => whnfE e'; Left done => Element e done
Right e' => whnfE e'
Left done => Element e done
export
notRedexNotCloE : (e : Elim {}) -> NotRedexE e -> NotCloE e
notRedexNotCloE (F x) f = NCF
notRedexNotCloE (B i) f = NCB
notRedexNotCloE (fun :@ arg) f = NCApp
notRedexNotCloE (fun :% arg) f = NCDApp
notRedexNotCloE (tm :# ty) f = NCAnn
notRedexNotCloE (CloE el th) f = absurd $ f IsCloE
notRedexNotCloE (DCloE el th) f = absurd $ f IsDCloE
export
notRedexNotCloT : (t : Term {}) -> NotRedexT t -> NotCloT t
notRedexNotCloT (TYPE _) _ = NCTYPE
notRedexNotCloT (Pi {}) _ = NCPi
notRedexNotCloT (Lam {}) _ = NCLam
notRedexNotCloT (Eq {}) _ = NCEq
notRedexNotCloT (DLam {}) _ = NCDLam
notRedexNotCloT (E e) f = NCE $ notRedexNotCloE e $ f . IsERedex
notRedexNotCloT (CloT {}) f = absurd $ f IsCloT
notRedexNotCloT (DCloT {}) f = absurd $ f IsDCloT
export
toNotCloE : NonRedexElim q d n -> NonCloElim q d n
toNotCloE (Element e prf) = Element e $ notRedexNotCloE e prf
export
toNotCloT : NonRedexTerm q d n -> NonCloTerm q d n
toNotCloT (Element t prf) = Element t $ notRedexNotCloT t prf

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

@ -10,41 +10,79 @@ import Data.Vect
public export public export
data IsLam : Term {} -> Type where data IsLam : Pred $ Term {} where ItIsLam : IsLam $ Lam x body
ItIsLam : IsLam $ Lam x body
public export %inline public export %inline
isLam : (s : Term {}) -> Dec (IsLam s) isLam : Dec1 IsLam
isLam (TYPE _) = No $ \case _ impossible isLam (TYPE _) = No $ \case _ impossible
isLam (Pi {}) = No $ \case _ impossible isLam (Pi {}) = No $ \case _ impossible
isLam (Lam {}) = Yes ItIsLam isLam (Lam {}) = Yes ItIsLam
isLam (Eq {}) = No $ \case _ impossible
isLam (DLam {}) = No $ \case _ impossible
isLam (E _) = No $ \case _ impossible isLam (E _) = No $ \case _ impossible
isLam (CloT {}) = No $ \case _ impossible isLam (CloT {}) = No $ \case _ impossible
isLam (DCloT {}) = No $ \case _ impossible isLam (DCloT {}) = No $ \case _ impossible
public export %inline public export
NotLam : Term {} -> Type 0 NotLam : Pred $ Term {}
NotLam = Not . IsLam NotLam = Not . IsLam
public export public export
data IsApp : Elim {} -> Type where data IsDLam : Pred $ Term {} where ItIsDLam : IsDLam $ DLam i body
ItIsApp : IsApp $ f :@ s
public export %inline public export %inline
isApp : (e : Elim {}) -> Dec (IsApp e) isDLam : Dec1 IsDLam
isDLam (TYPE _) = No $ \case _ impossible
isDLam (Pi {}) = No $ \case _ impossible
isDLam (Eq {}) = No $ \case _ impossible
isDLam (Lam {}) = No $ \case _ impossible
isDLam (DLam {}) = Yes ItIsDLam
isDLam (E _) = No $ \case _ impossible
isDLam (CloT {}) = No $ \case _ impossible
isDLam (DCloT {}) = No $ \case _ impossible
public export
0 NotDLam : Pred $ Term {}
NotDLam = Not . IsDLam
public export
data IsApp : Pred $ Elim {} where ItIsApp : IsApp $ f :@ s
public export %inline
isApp : Dec1 IsApp
isApp (F _) = No $ \case _ impossible isApp (F _) = No $ \case _ impossible
isApp (B _) = No $ \case _ impossible isApp (B _) = No $ \case _ impossible
isApp (_ :@ _) = Yes ItIsApp isApp (_ :@ _) = Yes ItIsApp
isApp (_ :% _) = No $ \case _ impossible
isApp (_ :# _) = No $ \case _ impossible isApp (_ :# _) = No $ \case _ impossible
isApp (CloE {}) = No $ \case _ impossible isApp (CloE {}) = No $ \case _ impossible
isApp (DCloE {}) = No $ \case _ impossible isApp (DCloE {}) = No $ \case _ impossible
public export public export
NotApp : Elim {} -> Type 0 NotApp : Pred $ Elim {}
NotApp = Not . IsApp NotApp = Not . IsApp
public export
data IsDApp : Pred $ Elim {} where ItIsDApp : IsDApp $ f :% d
public export %inline
isDApp : Dec1 IsDApp
isDApp (F _) = No $ \case _ impossible
isDApp (B _) = No $ \case _ impossible
isDApp (_ :@ _) = No $ \case _ impossible
isDApp (_ :% _) = Yes ItIsDApp
isDApp (_ :# _) = No $ \case _ impossible
isDApp (CloE {}) = No $ \case _ impossible
isDApp (DCloE {}) = No $ \case _ impossible
public export
0 NotDApp : Pred $ Elim {}
NotDApp = Not . IsDApp
infixl 9 :@@ infixl 9 :@@
||| apply multiple arguments at once ||| apply multiple arguments at once
public export %inline public export %inline
@ -61,8 +99,8 @@ record GetArgs q d n where
export export
getArgs' : Elim q d n -> List (Term q d n) -> GetArgs q d n getArgs' : Elim q d n -> List (Term q d n) -> GetArgs q d n
getArgs' fun args with (isApp fun) getArgs' fun args with (isApp fun)
getArgs' (f :@ a) args | Yes yes = getArgs' f (a :: args) getArgs' (f :@ a) args | Yes _ = getArgs' f (a :: args)
getArgs' fun args | No no = GotArgs {fun, args, notApp = no} getArgs' fun args | No no = GotArgs {fun, args, notApp = no}
||| splits an application into its head and arguments. if it's not an ||| splits an application into its head and arguments. if it's not an
||| application then the list is just empty ||| application then the list is just empty
@ -71,6 +109,32 @@ getArgs : Elim q d n -> GetArgs q d n
getArgs e = getArgs' e [] getArgs e = getArgs' e []
infixl 9 :%%
||| apply multiple dimension arguments at once
public export %inline
(:%%) : Elim q d n -> List (Dim d) -> Elim q d n
f :%% ss = foldl (:%) f ss
public export
record GetDArgs q d n where
constructor GotDArgs
fun : Elim q d n
args : List (Dim d)
0 notDApp : NotDApp fun
export
getDArgs' : Elim q d n -> List (Dim d) -> GetDArgs q d n
getDArgs' fun args with (isDApp fun)
getDArgs' (f :% a) args | Yes yes = getDArgs' f (a :: args)
getDArgs' fun args | No no = GotDArgs {fun, args, notDApp = no}
||| splits a dimension application into its head and arguments. if it's not an
||| d application then the list is just empty
export %inline
getDArgs : Elim q d n -> GetDArgs q d n
getDArgs e = getDArgs' e []
infixr 1 :\\ infixr 1 :\\
public export public export
absN : Vect m Name -> Term q d (m + n) -> Term q d n absN : Vect m Name -> Term q d (m + n) -> Term q d n
@ -83,9 +147,22 @@ public export %inline
(:\\) = absN (:\\) = absN
infixr 1 :\\%
public export
dabsN : Vect m Name -> 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
public export %inline
(:\\%) : Vect m Name -> Term q (m + d) n -> Term q d n
(:\\%) = dabsN
public export public export
record GetLams q d n where record GetLams q d n where
constructor GotLams constructor GotLams
{0 lams, rest : Nat}
names : Vect lams Name names : Vect lams Name
body : Term q d rest body : Term q d rest
0 eq : lams + n = rest 0 eq : lams + n = rest
@ -93,16 +170,38 @@ record GetLams q d n where
export export
getLams' : forall lams, rest. getLams' : forall lams, rest.
Vect lams Name -> Term q d rest -> lams + n = rest -> GetLams q d n Vect lams Name -> Term q d rest -> (0 eq : lams + n = rest) ->
GetLams q d n
getLams' xs s eq with (isLam s) getLams' xs s eq with (isLam s)
getLams' xs (Lam x sbody) Refl | Yes ItIsLam = getLams' xs (Lam x sbody) Refl | Yes _ =
let 0 s = Lam x sbody let body = assert_smaller (Lam x sbody) sbody.term in
body = assert_smaller s $ fromScopeTerm sbody
in
getLams' (x :: xs) body Refl getLams' (x :: xs) body Refl
getLams' xs s eq | No no = getLams' xs s eq | No no = GotLams xs s eq no
GotLams xs s eq no
export export %inline
getLams : Term q d n -> GetLams q d n getLams : Term q d n -> GetLams q d n
getLams s = getLams' [] s Refl getLams s = getLams' [] s Refl
public export
record GetDLams q d n where
constructor GotDLams
{0 lams, rest : Nat}
names : Vect lams Name
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) ->
GetDLams q d n
getDLams' is s eq with (isDLam s)
getDLams' is (DLam i sbody) Refl | Yes _ =
let body = assert_smaller (DLam i sbody) sbody.term in
getDLams' (i :: is) body Refl
getDLams' is s eq | No no = GotDLams is s eq no
export %inline
getDLams : Term q d n -> GetDLams q d n
getDLams s = getDLams' [] s Refl

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

@ -5,11 +5,61 @@ import Quox.Syntax.Term.Base
%default total %default total
export FromVar (Elim q d) where fromVar = B infixl 8 ///
export FromVar (Term q d) where fromVar = E . fromVar mutual
namespace Term
||| 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
(///) : Term q dfrom n -> DSubst dfrom dto -> Term q dto n
s /// Shift SZ = s
TYPE l /// _ = TYPE l
DCloT s ph /// th = DCloT s $ ph . th
s /// th = DCloT s th
namespace Elim
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
(///) : Elim q dfrom n -> DSubst dfrom dto -> Elim q dto n
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
namespace ScopeTerm
export
(///) : ScopeTerm q dfrom n -> DSubst dfrom dto -> ScopeTerm q dto n
TUsed body /// th = TUsed $ body /// th
TUnused body /// th = TUnused $ body /// th
namespace DScopeTerm
export
(///) : DScopeTerm q dfrom n -> DSubst dfrom dto -> DScopeTerm q dto n
DUsed body /// th = DUsed $ body /// push th
DUnused body /// th = DUnused $ body /// th
export %inline FromVar (Elim q d) where fromVar = B
export %inline FromVar (Term q d) where fromVar = E . fromVar
||| does the minimal reasonable work: ||| does the minimal reasonable work:
||| - deletes the closure around a free name since it doesn't do anything ||| - deletes the closure around a *free* name
||| - deletes an identity substitution ||| - deletes an identity substitution
||| - composes (lazily) with an existing top-level closure ||| - composes (lazily) with an existing top-level closure
||| - immediately looks up a bound variable ||| - immediately looks up a bound variable
@ -38,34 +88,30 @@ CanSubst (Elim q d) (Term q d) where
Shift SZ => s Shift SZ => s
th => CloT s th th => CloT s th
export export %inline
CanSubst (Elim q d) (ScopeTerm q d) where CanSubst (Elim q d) (ScopeTerm q d) where
TUsed body // th = TUsed $ body // push th TUsed body // th = TUsed $ body // push th
TUnused body // th = TUnused $ body // th TUnused body // th = TUnused $ body // th
export CanSubst Var (Term q d) where s // th = s // map (B {q, d}) th export %inline
export CanSubst Var (Elim q d) where e // th = e // map (B {q, d}) th CanSubst (Elim q d) (DScopeTerm q d) where
export CanSubst Var (ScopeTerm q d) where s // th = s // map (B {q, d}) th DUsed body // th = DUsed $ body // map (/// shift 1) th
DUnused body // th = DUnused $ body // th
export %inline CanSubst Var (Term q d) where s // th = s // map (B {q, d}) th
export %inline CanSubst Var (Elim q d) where e // th = e // map (B {q, d}) th
export %inline CanSubst Var (ScopeTerm q d) where s // th = s // map (B {q, d}) th
export %inline CanSubst Var (DScopeTerm q d) where s // th = s // map (B {q, d}) th
infixl 8 //., /// infixl 8 //., ///
mutual mutual
namespace Term namespace Term
||| applies a term substitution with a less ambiguous type ||| applies a term substitution with a less ambiguous type
export export %inline
(//.) : Term q d from -> TSubst q d from to -> Term q d to (//.) : Term q d from -> TSubst q d from to -> Term q d to
t //. th = t // th 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 ||| applies a term and dimension substitution
public export %inline public export %inline
subs : Term q dfrom from -> DSubst dfrom dto -> TSubst q dto from to -> subs : Term q dfrom from -> DSubst dfrom dto -> TSubst q dto from to ->
@ -74,20 +120,10 @@ mutual
namespace Elim namespace Elim
||| applies a term substitution with a less ambiguous type ||| applies a term substitution with a less ambiguous type
export export %inline
(//.) : Elim q d from -> TSubst q d from to -> Elim q d to (//.) : Elim q d from -> TSubst q d from to -> Elim q d to
e //. th = e // th 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 ||| applies a term and dimension substitution
public export %inline public export %inline
subs : Elim q dfrom from -> DSubst dfrom dto -> TSubst q dto from to -> subs : Elim q dfrom from -> DSubst dfrom dto -> TSubst q dto from to ->
@ -96,40 +132,65 @@ mutual
namespace ScopeTerm namespace ScopeTerm
||| applies a term substitution with a less ambiguous type ||| applies a term substitution with a less ambiguous type
export export %inline
(//.) : ScopeTerm q d from -> TSubst q d from to -> ScopeTerm q d to (//.) : ScopeTerm q d from -> TSubst q d from to -> ScopeTerm q d to
body //. th = body // th 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 ||| applies a term and dimension substitution
public export %inline public export %inline
subs : ScopeTerm q dfrom from -> DSubst dfrom dto -> TSubst q dto from to -> subs : ScopeTerm q dfrom from -> DSubst dfrom dto -> TSubst q dto from to ->
ScopeTerm q dto to ScopeTerm q dto to
subs body th ph = body /// th // ph subs body th ph = body /// th // ph
export CanShift (Term q d) where s // by = s //. Shift by namespace DScopeTerm
export CanShift (Elim q d) where e // by = e //. Shift by ||| applies a term substitution with a less ambiguous type
export CanShift (ScopeTerm q d) where s // by = s //. Shift by export %inline
(//.) : DScopeTerm q d from -> TSubst q d from to -> DScopeTerm q d to
body //. th = body // th
||| applies a term and dimension substitution
public export %inline
subs : DScopeTerm q dfrom from -> DSubst dfrom dto -> TSubst q dto from to ->
DScopeTerm q dto to
subs body th ph = body /// th // ph
export %inline CanShift (Term q d) where s // by = s //. Shift by
export %inline CanShift (Elim q d) where e // by = e //. Shift by
export %inline CanShift (ScopeTerm q d) where s // by = s //. Shift by
export %inline export %inline
comp' : DSubst dfrom dto -> TSubst q dfrom from mid -> TSubst q dto mid to -> comp : DSubst dfrom dto -> TSubst q dfrom from mid -> TSubst q dto mid to ->
TSubst q dto from to TSubst q dto from to
comp' th ps ph = map (/// th) ps . ph comp th ps ph = map (/// th) ps . ph
export namespace ScopeTerm
fromDScopeTerm : DScopeTerm q d n -> Term q (S d) n export %inline
fromDScopeTerm (DUsed body) = body (.term) : ScopeTerm q d n -> Term q d (S n)
fromDScopeTerm (DUnused body) = body /// shift 1 (TUsed body).term = body
(TUnused body).term = body //. shift 1
export namespace DScopeTerm
fromScopeTerm : ScopeTerm q d n -> Term q d (S n) export %inline
fromScopeTerm (TUsed body) = body (.term) : DScopeTerm q d n -> Term q (S d) n
fromScopeTerm (TUnused body) = body //. shift 1 (DUsed body).term = body
(DUnused body).term = body /// shift 1
export %inline
sub1 : ScopeTerm q d n -> Elim q d n -> Term q d n
sub1 (TUsed body) e = body // one e
sub1 (TUnused body) e = body
export %inline
dsub1 : DScopeTerm q d n -> Dim d -> Term q d n
dsub1 (DUsed body) p = body /// one p
dsub1 (DUnused body) p = body
public export %inline
(.zero) : DScopeTerm q d n -> Term q d n
body.zero = dsub1 body $ K Zero
public export %inline
(.one) : DScopeTerm q d n -> Term q d n
body.one = dsub1 body $ K One

8
lib/Quox/Syntax/Var.idr
View file

@ -282,11 +282,3 @@ decEqFromBool i j =
%transform "Var.decEq" varDecEq = decEqFromBool %transform "Var.decEq" varDecEq = decEqFromBool
public export %inline DecEq (Var n) where decEq = varDecEq public export %inline DecEq (Var n) where decEq = varDecEq
-- export
-- Tighten Var where
-- tighten Id i = pure i
-- tighten (Drop q) VZ = empty
-- tighten (Drop q) (VS i) = tighten q i
-- tighten (Keep q) VZ = pure VZ
-- tighten (Keep q) (VS i) = VS <$> tighten q i

133
lib/Quox/Typechecker.idr
View file

@ -9,6 +9,15 @@ import Decidable.Decidable
%default total %default total
public export
0 CanTC' : (q : Type) -> (q -> Type) -> (Type -> Type) -> Type
CanTC' q isGlobal m = (HasErr q m, MonadReader (Definitions' q isGlobal) m)
public export
0 CanTC : (q : Type) -> IsQty q => (Type -> Type) -> Type
CanTC q = CanTC' q IsGlobal
private covering %inline private covering %inline
expectTYPE : HasErr q m => Term q d n -> m Universe expectTYPE : HasErr q m => Term q d n -> m Universe
expectTYPE s = expectTYPE s =
@ -20,9 +29,17 @@ private covering %inline
expectPi : HasErr q m => Term q d n -> expectPi : HasErr q m => Term q d n ->
m (q, Term q d n, ScopeTerm q d n) m (q, Term q d n, ScopeTerm q d n)
expectPi ty = expectPi ty =
case (whnfT ty).fst of case whnfT ty of
Pi qty _ arg res => pure (qty, arg, res) Element (Pi qty _ arg res) _ => pure (qty, arg, res)
_ => throwError $ ExpectedPi ty _ => throwError $ ExpectedPi ty
private covering %inline
expectEq : HasErr q m => Term q d n ->
m (DScopeTerm q d n, Term q d n, Term q d n)
expectEq ty =
case whnfT ty of
Element (Eq _ ty l r) _ => pure (ty, l, r)
_ => throwError $ ExpectedEq ty
private %inline private %inline
expectEqualQ : HasErr q m => Eq q => expectEqualQ : HasErr q m => Eq q =>
@ -52,6 +69,12 @@ lookupBound pi VZ ctx@(MkTyContext {tctx = _ :< ty, _}) =
lookupBound pi (VS i) ctx = lookupBound pi (VS i) ctx =
weakI $ lookupBound pi i (tail ctx) weakI $ lookupBound pi i (tail ctx)
private
lookupFree : IsQty q => CanTC q m => Name -> m (Definition q)
lookupFree x =
case lookup x !ask of
Just d => pure d
Nothing => throwError $ NotInScope x
private %inline private %inline
subjMult : IsQty q => (sg : SQty q) -> q -> SQty q subjMult : IsQty q => (sg : SQty q) -> q -> SQty q
@ -65,14 +88,6 @@ makeDimEq (DBind dctx) = makeDimEq dctx :<? Nothing
makeDimEq (DEq p q dctx) = set p q $ makeDimEq dctx makeDimEq (DEq p q dctx) = set p q $ makeDimEq dctx
public export
0 CanTC' : (q : Type) -> (q -> Type) -> (Type -> Type) -> Type
CanTC' q isGlobal m = (HasErr q m, MonadReader (Definitions' q isGlobal) m)
public export
0 CanTC : (q : Type) -> IsQty q => (Type -> Type) -> Type
CanTC q = CanTC' q IsGlobal
parameters {auto _ : IsQty q} {auto _ : CanTC q m} parameters {auto _ : IsQty q} {auto _ : CanTC q m}
mutual mutual
-- [todo] it seems like the options here for dealing with substitutions are -- [todo] it seems like the options here for dealing with substitutions are
@ -80,76 +95,102 @@ parameters {auto _ : IsQty q} {auto _ : CanTC q m}
-- substitutions. both of them seem like the same amount of work for the -- substitutions. both of them seem like the same amount of work for the
-- computer but pushing is less work for the me -- computer but pushing is less work for the me
||| `check ctx sg subj ty` checks that in the context `ctx`, the term
||| `subj` has the type `ty`, with quantity `sg`. if so, returns the
||| quantities of all bound variables that it used.
export covering %inline export covering %inline
check : (ctx : TyContext q d n) -> (sg : SQty q) -> check : TyContext q d n -> SQty q -> Term q d n -> Term q d n ->
(subj : Term q d n) -> (ty : Term q d n) ->
m (CheckResult q n) m (CheckResult q n)
check ctx sg subj ty = check' ctx sg (pushSubstsT subj) ty check ctx sg subj ty =
let Element subj nc = pushSubstsT subj in
check' ctx sg subj nc ty
||| `infer ctx sg subj` infers the type of `subj` in the context `ctx`,
||| and returns its type and the bound variables it used.
export covering %inline export covering %inline
infer : (ctx : TyContext q d n) -> (sg : SQty q) -> infer : TyContext q d n -> SQty q -> Elim q d n -> m (InferResult q d n)
(subj : Elim q d n) -> infer ctx sg subj =
m (InferResult q d n) let Element subj nc = pushSubstsE subj in
infer ctx sg subj = infer' ctx sg (pushSubstsE subj) infer' ctx sg subj nc
export covering export covering
check' : (ctx : TyContext q d n) -> (sg : SQty q) -> check' : TyContext q d n -> SQty q ->
(subj : NotCloTerm q d n) -> (ty : Term q d n) -> (subj : Term q d n) -> (0 nc : NotCloT subj) -> Term q d n ->
m (CheckResult q n) m (CheckResult q n)
check' ctx sg (Element (TYPE l) _) ty = do check' ctx sg (TYPE l) _ ty = do
l' <- expectTYPE ty l' <- expectTYPE ty
expectEqualQ zero sg.fst expectEqualQ zero sg.fst
unless (l < l') $ throwError $ BadUniverse l l' unless (l < l') $ throwError $ BadUniverse l l'
pure $ zeroFor ctx pure $ zeroFor ctx
check' ctx sg (Element (Pi qty x arg res) _) ty = do check' ctx sg (Pi qty x arg res) _ ty = do
l <- expectTYPE ty l <- expectTYPE ty
expectEqualQ zero sg.fst expectEqualQ zero sg.fst
ignore $ check ctx szero arg (TYPE l) ignore $ check ctx szero arg (TYPE l)
case res of case res of
TUsed res => TUsed res => ignore $ check (extendTy arg zero ctx) szero res (TYPE l)
ignore $ check (extendTy arg zero ctx) szero res (TYPE l) TUnused res => ignore $ check ctx szero res (TYPE l)
TUnused res =>
ignore $ check ctx szero res (TYPE l)
pure $ zeroFor ctx pure $ zeroFor ctx
check' ctx sg (Element (Lam x body) _) ty = do check' ctx sg (Lam x body) _ ty = do
(qty, arg, res) <- expectPi ty (qty, arg, res) <- expectPi ty
-- [todo] do this properly? qout <- check (extendTy arg (sg.fst * qty) ctx) sg body.term res.term
let body = fromScopeTerm body; res = fromScopeTerm res
qout <- check (extendTy arg (sg.fst * qty) ctx) sg body res
popQ qty qout popQ qty qout
check' ctx sg (Element (E e) _) ty = do check' ctx sg (Eq i t l r) _ ty = do
u <- expectTYPE ty
expectEqualQ zero sg.fst
case t of
DUsed t => ignore $ check (extendDim ctx) sg t (TYPE u)
DUnused t => ignore $ check ctx sg t (TYPE u)
ignore $ check ctx sg t.zero l
ignore $ check ctx sg t.one r
pure $ zeroFor ctx
check' ctx sg (DLam i body) _ ty = do
(ty, l, r) <- expectEq ty
qout <- check (extendDim ctx) sg body.term ty.term
let eqs = makeDimEq ctx.dctx
equalTWith eqs body.zero l
equalTWith eqs body.one r
pure qout
check' ctx sg (E e) _ ty = do
infres <- infer ctx sg e infres <- infer ctx sg e
ignore $ check ctx szero ty (TYPE UAny) ignore $ check ctx szero ty (TYPE UAny)
subTWith (makeDimEq ctx.dctx) infres.type ty subTWith (makeDimEq ctx.dctx) infres.type ty
pure infres.qout pure infres.qout
export covering export covering
infer' : (ctx : TyContext q d n) -> (sg : SQty q) -> infer' : TyContext q d n -> SQty q ->
(subj : NotCloElim q d n) -> (subj : Elim q d n) -> (0 nc : NotCloE subj) ->
m (InferResult q d n) m (InferResult q d n)
infer' ctx sg (Element (F x) _) = do infer' ctx sg (F x) _ = do
Just g <- asks $ lookup x | Nothing => throwError $ NotInScope x g <- lookupFree x
when (isZero g) $ expectEqualQ sg.fst zero when (isYes $ isZero g) $ expectEqualQ sg.fst zero
pure $ InfRes {type = g.type.get, qout = zeroFor ctx} pure $ InfRes {type = g.type.get, qout = zeroFor ctx}
infer' ctx sg (Element (B i) _) = infer' ctx sg (B i) _ =
pure $ lookupBound sg.fst i ctx pure $ lookupBound sg.fst i ctx
infer' ctx sg (Element (fun :@ arg) _) = do infer' ctx sg (fun :@ arg) _ = do
funres <- infer ctx sg fun funres <- infer ctx sg fun
(qty, argty, res) <- expectPi funres.type (qty, argty, res) <- expectPi funres.type
let sg' = subjMult sg qty argout <- check ctx (subjMult sg qty) arg argty
argout <- check ctx sg' arg argty pure $ InfRes {
pure $ InfRes {type = fromScopeTerm res //. ((arg :# argty) ::: id), type = sub1 res $ arg :# argty,
qout = funres.qout + argout} qout = funres.qout + argout
}
infer' ctx sg (Element (tm :# ty) _) = do infer' ctx sg (fun :% dim) _ = do
ignore $ check ctx szero ty (TYPE UAny) InfRes {type, qout} <- infer ctx sg fun
qout <- check ctx sg tm ty (ty, _, _) <- expectEq type
pure $ InfRes {type = ty, qout} pure $ InfRes {type = dsub1 ty dim, qout}
infer' ctx sg (term :# type) _ = do
ignore $ check ctx szero type (TYPE UAny)
qout <- check ctx sg term type
pure $ InfRes {type, qout}

2
lib/Quox/Typing.idr
View file

@ -106,11 +106,13 @@ public export
data Error q data Error q
= ExpectedTYPE (Term q d n) = ExpectedTYPE (Term q d n)
| ExpectedPi (Term q d n) | ExpectedPi (Term q d n)
| ExpectedEq (Term q d n)
| BadUniverse Universe Universe | BadUniverse Universe Universe
| ClashT EqMode (Term q d n) (Term q d n) | ClashT EqMode (Term q d n) (Term q d n)
| ClashU EqMode Universe Universe | ClashU EqMode Universe Universe
| ClashQ q q | ClashQ q q
| ClashD (Dim d) (Dim d)
| NotInScope Name | NotInScope Name
public export public export

17
tests/TermImpls.idr
View file

@ -33,6 +33,13 @@ mutual
Lam _ body1 == Lam _ body2 = body1 == body2 Lam _ body1 == Lam _ body2 = body1 == body2
Lam {} == _ = False Lam {} == _ = False
Eq _ ty1 l1 r1 == Eq _ ty2 l2 r2 =
ty1 == ty2 && l1 == l2 && r1 == r2
Eq {} == _ = False
DLam _ body1 == DLam _ body2 = body1 == body2
DLam {} == _ = False
E e == E f = e == f E e == E f = e == f
E _ == _ = False E _ == _ = False
@ -62,6 +69,9 @@ mutual
(tm1 :# ty1) == (tm2 :# ty2) = tm1 == tm2 && ty1 == ty2 (tm1 :# ty1) == (tm2 :# ty2) = tm1 == tm2 && ty1 == ty2
(_ :# _) == _ = False (_ :# _) == _ = False
(fun1 :% dim1) == (fun2 :% dim2) = fun1 == fun2 && dim1 == dim2
(_ :% _) == _ = False
CloE el1 th1 == CloE el2 th2 = CloE el1 th1 == CloE el2 th2 =
case eqSubst th1 th2 of case eqSubst th1 th2 of
Just Refl => el1 == el2 && th1 == th2 Just Refl => el1 == el2 && th1 == th2
@ -81,6 +91,13 @@ mutual
TUsed _ == TUnused _ = False TUsed _ == TUnused _ = False
TUnused _ == TUsed _ = False TUnused _ == TUsed _ = False
export covering
Eq q => Eq (DScopeTerm q d n) where
DUsed s == DUsed t = s == t
DUnused s == DUnused t = s == t
DUsed _ == DUnused _ = False
DUnused _ == DUsed _ = False
export covering export covering
PrettyHL q => Show (Term q d n) where PrettyHL q => Show (Term q d n) where
showPrec d t = showParens (d /= Open) $ prettyStr True t showPrec d t = showParens (d /= Open) $ prettyStr True t

17
tests/Tests/Equal.idr
View file

@ -16,6 +16,9 @@ ToInfo (Error Three) where
toInfo (ExpectedPi t) = toInfo (ExpectedPi t) =
[("type", "ExpectedPi"), [("type", "ExpectedPi"),
("got", prettyStr True t)] ("got", prettyStr True t)]
toInfo (ExpectedEq t) =
[("type", "ExpectedEq"),
("got", prettyStr True t)]
toInfo (BadUniverse k l) = toInfo (BadUniverse k l) =
[("type", "BadUniverse"), [("type", "BadUniverse"),
("low", show k), ("low", show k),
@ -34,6 +37,10 @@ ToInfo (Error Three) where
[("type", "ClashQ"), [("type", "ClashQ"),
("left", prettyStr True pi), ("left", prettyStr True pi),
("right", prettyStr True rh)] ("right", prettyStr True rh)]
toInfo (ClashD p q) =
[("type", "ClashD"),
("left", prettyStr True p),
("right", prettyStr True q)]
0 M : Type -> Type 0 M : Type -> Type
@ -127,6 +134,16 @@ tests = "equality & subtyping" :- [
subT tm1 tm2 subT tm1 tm2
], ],
"eq type" :- [
testEq "(★₀ = ★₀ : ★₁) ≡ (★₀ = ★₀ : ★₁)" $
let tm = Eq0 (TYPE 1) (TYPE 0) (TYPE 0) in
equalT tm tm,
testEq "A ≔ ★₁ ⊢ (★₀ = ★₀ : ★₁) ≡ (★₀ = ★₀ : A)"
{globals = fromList [("A", mkDef zero (TYPE 2) (TYPE 1))]} $
equalT (Eq0 (TYPE 1) (TYPE 0) (TYPE 0))
(Eq0 (FT "A") (TYPE 0) (TYPE 0))
],
"lambda" :- [ "lambda" :- [
testEq "λ x ⇒ [x] ≡ λ x ⇒ [x]" $ testEq "λ x ⇒ [x] ≡ λ x ⇒ [x]" $
equalT (Lam "x" $ TUsed $ BVT 0) (Lam "x" $ TUsed $ BVT 0), equalT (Lam "x" $ TUsed $ BVT 0) (Lam "x" $ TUsed $ BVT 0),