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

fix warnings

Browse source
This commit is contained in:
rhiannon morris 2023-09-19 18:05:43 +02:00
parent 80b1b3581a
commit dc076b636d
2 changed files with 29 additions and 25 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
lib/Quox/FreeVars.idr
View file

@ -84,19 +84,19 @@ toSet (FV vs) =
public export public export
interface HasFreeVars (0 term : Nat -> Type) where interface HasFreeVars (0 tm : Nat -> Type) where
constructor HFV constructor HFV
fv : {n : Nat} -> term n -> FreeVars n fv : {n : Nat} -> tm n -> FreeVars n
public export public export
interface HasFreeDVars (0 term : TermLike) where interface HasFreeDVars (0 tm : TermLike) where
constructor HFDV constructor HFDV
fdv : {d, n : Nat} -> term d n -> FreeVars d fdv : {d, n : Nat} -> tm d n -> FreeVars d
export export
Fdv : (0 term : TermLike) -> {n : Nat} -> Fdv : (0 tm : TermLike) -> {n : Nat} ->
HasFreeDVars term => HasFreeVars (\d => term d n) HasFreeDVars tm => HasFreeVars (\d => tm d n)
Fdv term @{HFDV fdv} = HFV fdv Fdv tm @{HFDV fdv} = HFV fdv
export export
@ -119,26 +119,26 @@ HasFreeVars Dim where
export export
{s : Nat} -> HasFreeVars term => HasFreeVars (Scoped s term) where {s : Nat} -> HasFreeVars tm => HasFreeVars (Scoped s tm) where
fv (S _ (Y body)) = FV $ drop s (fv body).vars fv (S _ (Y body)) = FV $ drop s (fv body).vars
fv (S _ (N body)) = fv body fv (S _ (N body)) = fv body
export export
implementation [DScope] implementation [DScope]
{s : Nat} -> HasFreeDVars term => {s : Nat} -> HasFreeDVars tm =>
HasFreeDVars (\d, n => Scoped s (\d' => term d' n) d) HasFreeDVars (\d, n => Scoped s (\d' => tm d' n) d)
where where
fdv (S _ (Y body)) = FV $ drop s (fdv body).vars fdv (S _ (Y body)) = FV $ drop s (fdv body).vars
fdv (S _ (N body)) = fdv body fdv (S _ (N body)) = fdv body
export export
fvD : {0 term : TermLike} -> {n : Nat} -> (forall d. HasFreeVars (term d)) => fvD : {0 tm : TermLike} -> {n : Nat} -> (forall d. HasFreeVars (tm d)) =>
Scoped s (\d => term d n) d -> FreeVars n Scoped s (\d => tm d n) d -> FreeVars n
fvD (S _ (Y body)) = fv body fvD (S _ (Y body)) = fv body
fvD (S _ (N body)) = fv body fvD (S _ (N body)) = fv body
export export
fdvT : HasFreeDVars term => {s, d, n : Nat} -> Scoped s (term d) n -> FreeVars d fdvT : HasFreeDVars tm => {s, d, n : Nat} -> Scoped s (tm d) n -> FreeVars d
fdvT (S _ (Y body)) = fdv body fdvT (S _ (Y body)) = fdv body
fdvT (S _ (N body)) = fdv body fdvT (S _ (N body)) = fdv body
@ -149,8 +149,8 @@ guardM b x = if b then x else neutral
export export
implementation implementation
(HasFreeVars term, HasFreeVars env) => (HasFreeVars tm, HasFreeVars env) =>
HasFreeVars (WithSubst term env) HasFreeVars (WithSubst tm env)
where where
fv (Sub term subst) = fv (Sub term subst) =
let Val from = getFrom subst in let Val from = getFrom subst in
@ -158,8 +158,8 @@ where
export export
implementation [WithSubst] implementation [WithSubst]
((forall d. HasFreeVars (term d)), HasFreeDVars term, HasFreeDVars env) => ((forall d. HasFreeVars (tm d)), HasFreeDVars tm, HasFreeDVars env) =>
HasFreeDVars (\d => WithSubst (term d) (env d)) HasFreeDVars (\d => WithSubst (tm d) (env d))
where where
fdv (Sub term subst) = fdv (Sub term subst) =
let Val from = getFrom subst in let Val from = getFrom subst in
@ -227,8 +227,8 @@ expandDSubst (t ::: th) = expandDSubst th :< t
private private
fdvSubst' : {d1, d2, n : Nat} -> HasFreeDVars term => fdvSubst' : {d1, d2, n : Nat} -> HasFreeDVars tm =>
term d1 n -> DSubst d1 d2 -> FreeVars d2 tm d1 n -> DSubst d1 d2 -> FreeVars d2
fdvSubst' t th = fdvSubst' t th =
fold $ zipWith maybeOnly (fdv t).vars (expandDSubst th) fold $ zipWith maybeOnly (fdv t).vars (expandDSubst th)
where where
@ -237,8 +237,8 @@ where
maybeOnly _ _ = none maybeOnly _ _ = none
private private
fdvSubst : {d, n : Nat} -> HasFreeDVars term => fdvSubst : {d, n : Nat} -> HasFreeDVars tm =>
WithSubst (\d => term d n) Dim d -> FreeVars d WithSubst (\d => tm d n) Dim d -> FreeVars d
fdvSubst (Sub t th) = let Val from = getFrom th in fdvSubst' t th fdvSubst (Sub t th) = let Val from = getFrom th in fdvSubst' t th

12
tests/Tests/FreeVars.idr
View file

@ -38,17 +38,21 @@ testFreeVars lbl tm dims terms =
Right () Right ()
private private
prettyWith : (a -> Eff Pretty (Doc (Opts 80))) -> a -> String Doc80 : Type
Doc80 = Doc $ Opts 80
private
prettyWith : (a -> Eff Pretty Doc80) -> a -> String
prettyWith f = trim . render _ . runPretty . f prettyWith f = trim . render _ . runPretty . f
parameters {d, n : Nat} (ds : BContext d) (ts : BContext n) parameters {d, n : Nat} (ds : BContext d) (ts : BContext n)
private private
withContext : {opts : _} -> Doc opts -> Eff Pretty (Doc opts) withContext : Doc80 -> Eff Pretty Doc80
withContext {opts} doc = withContext doc =
if null ds && null ts then pure $ hsep ["⊢", doc] if null ds && null ts then pure $ hsep ["⊢", doc]
else pure $ sep [hsep [!(ctx1 ds), "|", !(ctx1 ts), "⊢"], doc] else pure $ sep [hsep [!(ctx1 ds), "|", !(ctx1 ts), "⊢"], doc]
where where
ctx1 : forall k. BContext k -> Eff Pretty (Doc opts) ctx1 : forall k. BContext k -> Eff Pretty Doc80
ctx1 [<] = pure "·" ctx1 [<] = pure "·"
ctx1 ctx = fillSeparateTight !commaD . toList' <$> ctx1 ctx = fillSeparateTight !commaD . toList' <$>
traverse' (pure . prettyBind') ctx traverse' (pure . prettyBind') ctx