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

make uses of eff more consistent

Browse source
This commit is contained in:
rhiannon morris 2023-08-24 19:55:57 +02:00
parent 8264a1bb81
commit 4b6b3853a1
5 changed files with 81 additions and 76 deletions
Download patch file Download diff file Expand all files Collapse all files

8
tests/Tests/Equal.idr
View file

@ -20,7 +20,7 @@ defGlobals = fromList
("eq-AB", ^mkPostulate gzero (^Eq0 (^TYPE 0) (^FT "A" 0) (^FT "B" 0))),
("two", ^mkDef gany (^Nat) (^Succ (^Succ (^Zero))))]
parameters (label : String) (act : Equal ())
parameters (label : String) (act : Eff Equal ())
{default defGlobals globals : Definitions}
testEq : Test
testEq = test label $ runEqual globals act
@ -30,13 +30,13 @@ parameters (label : String) (act : Equal ())
parameters (ctx : TyContext d n)
subT, equalT : Term d n -> Term d n -> Term d n -> TC ()
subT, equalT : Term d n -> Term d n -> Term d n -> Eff TC ()
subT ty s t = lift $ Term.sub noLoc ctx ty s t
equalT ty s t = lift $ Term.equal noLoc ctx ty s t
equalTy : Term d n -> Term d n -> TC ()
equalTy : Term d n -> Term d n -> Eff TC ()
equalTy s t = lift $ Term.equalType noLoc ctx s t
subE, equalE : Elim d n -> Elim d n -> TC ()
subE, equalE : Elim d n -> Elim d n -> Eff TC ()
subE e f = lift $ Elim.sub noLoc ctx e f
equalE e f = lift $ Elim.equal noLoc ctx e f

24
tests/Tests/Typechecker.idr
View file

@ -30,10 +30,10 @@ ToInfo Error' where
("wanted", show good),
("wanted", show bad)]
0 M : Type -> Type
M = Eff [Except Error', DefsReader]
0 Test : List (Type -> Type)
Test = [Except Error', DefsReader]
inj : TC a -> M a
inj : Eff TC a -> Eff Test a
inj act = rethrow $ mapFst TCError $ runTC !(askAt DEFS) act
@ -109,7 +109,7 @@ defGlobals = fromList
("fst", ^mkDef gany fstTy fstDef),
("snd", ^mkDef gany sndTy sndDef)]
parameters (label : String) (act : Lazy (M ()))
parameters (label : String) (act : Lazy (Eff Test ()))
{default defGlobals globals : Definitions}
testTC : Test
testTC = test label {e = Error', a = ()} $
@ -120,22 +120,22 @@ parameters (label : String) (act : Lazy (M ()))
(extract $ runExcept $ runReaderAt DEFS globals act) $> "()"
inferredTypeEq : TyContext d n -> (exp, got : Term d n) -> M ()
inferredTypeEq : TyContext d n -> (exp, got : Term d n) -> Eff Test ()
inferredTypeEq ctx exp got =
wrapErr (const $ WrongInfer ctx.dnames ctx.tnames exp got) $ inj $ lift $
equalType noLoc ctx exp got
qoutEq : (exp, got : QOutput n) -> M ()
qoutEq : (exp, got : QOutput n) -> Eff Test ()
qoutEq qout res = unless (qout == res) $ throw $ WrongQOut qout res
inferAs : TyContext d n -> (sg : SQty) -> Elim d n -> Term d n -> M ()
inferAs : TyContext d n -> (sg : SQty) -> Elim d n -> Term d n -> Eff Test ()
inferAs ctx@(MkTyContext {dctx, _}) sg e ty = do
case !(inj $ infer ctx sg e) of
Just res => inferredTypeEq ctx ty res.type
Nothing => pure ()
inferAsQ : TyContext d n -> (sg : SQty) ->
Elim d n -> Term d n -> QOutput n -> M ()
Elim d n -> Term d n -> QOutput n -> Eff Test ()
inferAsQ ctx@(MkTyContext {dctx, _}) sg e ty qout = do
case !(inj $ infer ctx sg e) of
Just res => do
@ -143,20 +143,20 @@ inferAsQ ctx@(MkTyContext {dctx, _}) sg e ty qout = do
qoutEq qout res.qout
Nothing => pure ()
infer_ : TyContext d n -> (sg : SQty) -> Elim d n -> M ()
infer_ : TyContext d n -> (sg : SQty) -> Elim d n -> Eff Test ()
infer_ ctx sg e = ignore $ inj $ infer ctx sg e
checkQ : TyContext d n -> SQty ->
Term d n -> Term d n -> QOutput n -> M ()
Term d n -> Term d n -> QOutput n -> Eff Test ()
checkQ ctx@(MkTyContext {dctx, _}) sg s ty qout = do
case !(inj $ check ctx sg s ty) of
Just res => qoutEq qout res
Nothing => pure ()
check_ : TyContext d n -> SQty -> Term d n -> Term d n -> M ()
check_ : TyContext d n -> SQty -> Term d n -> Term d n -> Eff Test ()
check_ ctx sg s ty = ignore $ inj $ check ctx sg s ty
checkType_ : TyContext d n -> Term d n -> Maybe Universe -> M ()
checkType_ : TyContext d n -> Term d n -> Maybe Universe -> Eff Test ()
checkType_ ctx s u = inj $ checkType ctx s u