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

represent ℕ constants directly

Browse source 
instead of as huge `succ (succ (succ ⋯))` terms
This commit is contained in:
rhiannon morris 2023-11-02 20:01:34 +01:00
parent fa7f82ae5a
commit 0514fff481
18 changed files with 104 additions and 115 deletions
Download patch file Download diff file Expand all files Collapse all files

23
lib/Quox/Whnf/Interface.idr
View file

@ -84,11 +84,18 @@ isTagHead _ = False
||| an expression like `0 ∷ ℕ` or `suc n ∷ ℕ`
public export %inline
isNatHead : Elim {} -> Bool
isNatHead (Ann (Zero {}) (NAT {}) _) = True
isNatHead (Ann (Nat {}) (NAT {}) _) = True
isNatHead (Ann (Succ {}) (NAT {}) _) = True
isNatHead (Coe {}) = True
isNatHead _ = False
||| a natural constant, with or without an annotation
public export %inline
isNatConst : Term d n -> Bool
isNatConst (Nat {}) = True
isNatConst (E (Ann (Nat {}) _ _)) = True
isNatConst _ = False
||| an expression like `[s] ∷ [π. A]`
public export %inline
isBoxHead : Elim {} -> Bool
@ -122,7 +129,7 @@ isTyCon (Tag {}) = False
isTyCon (Eq {}) = True
isTyCon (DLam {}) = False
isTyCon (NAT {}) = True
isTyCon (Zero {}) = False
isTyCon (Nat {}) = False
isTyCon (Succ {}) = False
isTyCon (STRING {}) = True
isTyCon (Str {}) = False
@ -169,7 +176,7 @@ canPushCoe sg (Tag {}) _ = False
canPushCoe sg (Eq {}) _ = True
canPushCoe sg (DLam {}) _ = False
canPushCoe sg (NAT {}) _ = True
canPushCoe sg (Zero {}) _ = False
canPushCoe sg (Nat {}) _ = False
canPushCoe sg (Succ {}) _ = False
canPushCoe sg (STRING {}) _ = True
canPushCoe sg (Str {}) _ = False
@ -235,9 +242,11 @@ mutual
||| 2. an annotated elimination
||| (the annotation is redundant in a checkable context)
||| 3. a closure
||| 4. `succ` applied to a natural constant
public export
isRedexT : RedexTest Term
isRedexT _ _ (CloT {}) = True
isRedexT _ _ (DCloT {}) = True
isRedexT defs sg (E {e, _}) = isAnn e || isRedexE defs sg e
isRedexT _ _ _ = False
isRedexT _ _ (CloT {}) = True
isRedexT _ _ (DCloT {}) = True
isRedexT defs sg (E {e, _}) = isAnn e || isRedexE defs sg e
isRedexT _ _ (Succ p {}) = isNatConst p
isRedexT _ _ _ = False

17
lib/Quox/Whnf/Main.idr
View file

@ -113,8 +113,13 @@ CanWhnf Elim Interface.isRedexE where
Left _ =>
let ty = sub1 ret nat in
case nat of
Ann (Zero _) (NAT _) _ =>
Ann (Nat 0 _) (NAT _) _ =>
whnf defs ctx sg $ Ann zer ty zer.loc
Ann (Nat (S n) succLoc) (NAT natLoc) _ =>
let nn = Ann (Nat n succLoc) (NAT natLoc) succLoc
tm = subN suc [< nn, CaseNat pi piIH nn ret zer suc caseLoc]
in
whnf defs ctx sg $ Ann tm ty caseLoc
Ann (Succ n succLoc) (NAT natLoc) _ =>
let nn = Ann n (NAT natLoc) succLoc
tm = subN suc [< nn, CaseNat pi piIH nn ret zer suc caseLoc]
@ -236,13 +241,19 @@ CanWhnf Term Interface.isRedexT where
whnf _ _ _ t@(Eq {}) = pure $ nred t
whnf _ _ _ t@(DLam {}) = pure $ nred t
whnf _ _ _ t@(NAT {}) = pure $ nred t
whnf _ _ _ t@(Zero {}) = pure $ nred t
whnf _ _ _ t@(Succ {}) = pure $ nred t
whnf _ _ _ t@(Nat {}) = pure $ nred t
whnf _ _ _ t@(STRING {}) = pure $ nred t
whnf _ _ _ t@(Str {}) = pure $ nred t
whnf _ _ _ t@(BOX {}) = pure $ nred t
whnf _ _ _ t@(Box {}) = pure $ nred t
whnf _ _ _ (Succ p loc) =
case nchoose $ isNatConst p of
Left _ => case p of
Nat p _ => pure $ nred $ Nat (S p) loc
E (Ann (Nat p _) _ _) => pure $ nred $ Nat (S p) loc
Right nc => pure $ Element (Succ p loc) $ ?cc
-- s ∷ A ⇝ s (in term context)
whnf defs ctx sg (E e) = do
Element e enf <- whnf defs ctx sg e