quox/lib/Quox/Typing.idr

168 lines
5.3 KiB
Idris
Raw Normal View History

2021-12-23 13:05:50 -05:00
module Quox.Typing
2023-03-13 16:41:57 -04:00
import public Quox.Typing.Context as Typing
import public Quox.Typing.EqMode as Typing
import public Quox.Typing.Error as Typing
2021-12-23 13:05:50 -05:00
import public Quox.Syntax
2022-08-22 04:17:08 -04:00
import public Quox.Definition
2023-08-24 12:42:26 -04:00
import public Quox.Whnf
2021-12-23 13:05:50 -05:00
2023-04-15 09:13:01 -04:00
import Language.Reflection
2023-03-31 13:23:30 -04:00
import Control.Eff
%default total
2023-04-15 09:13:01 -04:00
%language ElabReflection
private TTName : Type
TTName = TT.Name
%hide TT.Name
2021-12-23 13:05:50 -05:00
2022-04-23 18:21:30 -04:00
public export
2023-04-01 13:16:43 -04:00
CheckResult' : Nat -> Type
2023-02-19 11:51:44 -05:00
CheckResult' = QOutput
2022-04-23 18:21:30 -04:00
public export
2023-04-01 13:16:43 -04:00
CheckResult : DimEq d -> Nat -> Type
CheckResult eqs n = IfConsistent eqs $ CheckResult' n
2023-02-19 11:51:44 -05:00
public export
2023-04-01 13:16:43 -04:00
record InferResult' d n where
2022-04-23 18:21:30 -04:00
constructor InfRes
2023-04-01 13:16:43 -04:00
type : Term d n
qout : QOutput n
2022-04-23 18:21:30 -04:00
2023-02-19 11:51:44 -05:00
public export
InferResult : DimEq d -> TermLike
2023-04-01 13:16:43 -04:00
InferResult eqs d n = IfConsistent eqs $ InferResult' d n
2023-02-19 11:51:44 -05:00
2022-04-23 18:21:30 -04:00
2023-02-10 15:40:44 -05:00
export
2023-05-01 21:06:25 -04:00
lookupFree : Has ErrorEff fs => Name -> Loc -> Definitions -> Eff fs Definition
lookupFree x loc defs = maybe (throw $ NotInScope loc x) pure $ lookup x defs
2023-02-10 15:40:44 -05:00
2023-02-12 15:30:08 -05:00
public export
2023-05-01 21:06:25 -04:00
substCasePairRet : BContext 2 -> Term d n -> ScopeTerm d n -> Term d (2 + n)
substCasePairRet [< x, y] dty retty =
let tm = Pair (BVT 1 x.loc) (BVT 0 y.loc) $ x.loc `extendL` y.loc
arg = Ann tm (dty // fromNat 2) tm.loc
in
2023-02-10 15:40:44 -05:00
retty.term // (arg ::: shift 2)
2023-02-11 12:15:50 -05:00
2023-03-26 08:40:54 -04:00
public export
2023-05-01 21:06:25 -04:00
substCaseSuccRet : BContext 2 -> ScopeTerm d n -> Term d (2 + n)
substCaseSuccRet [< p, ih] retty =
2023-11-02 13:14:22 -04:00
let arg = Ann (Succ (BVT 1 p.loc) p.loc) (NAT noLoc) $ p.loc `extendL` ih.loc
2023-05-01 21:06:25 -04:00
in
retty.term // (arg ::: shift 2)
2023-03-26 08:40:54 -04:00
2023-03-31 13:11:35 -04:00
public export
2023-05-01 21:06:25 -04:00
substCaseBoxRet : BindName -> Term d n -> ScopeTerm d n -> Term d (S n)
substCaseBoxRet x dty retty =
let arg = Ann (Box (BVT 0 x.loc) x.loc) (weakT 1 dty) x.loc in
retty.term // (arg ::: shift 1)
2023-02-11 12:15:50 -05:00
2023-03-31 13:23:30 -04:00
2023-05-01 21:06:25 -04:00
parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)}
2023-04-15 09:13:01 -04:00
namespace TyContext
parameters (ctx : TyContext d n) (sg : SQty) (loc : Loc)
2023-04-15 09:13:01 -04:00
export covering
2023-05-21 14:11:01 -04:00
whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
tm d n -> Eff fs (NonRedex tm d n defs sg)
2023-05-01 21:06:25 -04:00
whnf tm = do
let Val n = ctx.termLen; Val d = ctx.dimLen
res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm
2023-05-01 21:06:25 -04:00
rethrow res
2023-04-15 09:13:01 -04:00
private covering %macro
2023-05-01 21:06:25 -04:00
expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> Error) ->
2023-04-15 09:13:01 -04:00
TTImp -> TTImp -> Elab (Term d n -> Eff fs a)
expect k l r = do
f <- check `(\case ~(l) => Just ~(r); _ => Nothing)
2023-05-01 21:06:25 -04:00
pure $ \t => maybe (throw $ k loc ctx.names t) pure . f . fst =<< whnf t
2023-02-11 12:15:50 -05:00
export covering %inline
2023-04-01 13:16:43 -04:00
expectTYPE : Term d n -> Eff fs Universe
2023-05-01 21:06:25 -04:00
expectTYPE = expect ExpectedTYPE `(TYPE {l, _}) `(l)
export covering %inline
2023-04-01 13:16:43 -04:00
expectPi : Term d n -> Eff fs (Qty, Term d n, ScopeTerm d n)
2023-05-01 21:06:25 -04:00
expectPi = expect ExpectedPi `(Pi {qty, arg, res, _}) `((qty, arg, res))
export covering %inline
2023-04-01 13:16:43 -04:00
expectSig : Term d n -> Eff fs (Term d n, ScopeTerm d n)
2023-05-01 21:06:25 -04:00
expectSig = expect ExpectedSig `(Sig {fst, snd, _}) `((fst, snd))
export covering %inline
2023-04-01 13:16:43 -04:00
expectEnum : Term d n -> Eff fs (SortedSet TagVal)
2023-05-01 21:06:25 -04:00
expectEnum = expect ExpectedEnum `(Enum {cases, _}) `(cases)
export covering %inline
2023-04-01 13:16:43 -04:00
expectEq : Term d n -> Eff fs (DScopeTerm d n, Term d n, Term d n)
2023-05-01 21:06:25 -04:00
expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r))
2023-03-26 08:40:54 -04:00
export covering %inline
2023-11-02 13:14:22 -04:00
expectNAT : Term d n -> Eff fs ()
expectNAT = expect ExpectedNAT `(NAT {}) `(())
2023-03-26 08:40:54 -04:00
export covering %inline
expectSTRING : Term d n -> Eff fs ()
expectSTRING = expect ExpectedSTRING `(STRING {}) `(())
2023-03-31 13:11:35 -04:00
export covering %inline
2023-04-01 13:16:43 -04:00
expectBOX : Term d n -> Eff fs (Qty, Term d n)
2023-05-01 21:06:25 -04:00
expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty))
2023-04-15 09:13:01 -04:00
namespace EqContext
parameters (ctx : EqContext n) (sg : SQty) (loc : Loc)
2023-04-15 09:13:01 -04:00
export covering
2023-05-21 14:11:01 -04:00
whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex =>
tm 0 n -> Eff fs (NonRedex tm 0 n defs sg)
2023-05-01 21:06:25 -04:00
whnf tm = do
res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm
2023-05-01 21:06:25 -04:00
rethrow res
2023-03-31 13:11:35 -04:00
2023-04-15 09:13:01 -04:00
private covering %macro
2023-05-01 21:06:25 -04:00
expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> Error) ->
2023-04-15 09:13:01 -04:00
TTImp -> TTImp -> Elab (Term 0 n -> Eff fs a)
expect k l r = do
f <- check `(\case ~(l) => Just ~(r); _ => Nothing)
pure $ \t =>
2023-05-01 21:06:25 -04:00
let err = throw $ k loc ctx.names (t // shift0 ctx.dimLen) in
2023-04-15 09:13:01 -04:00
maybe err pure . f . fst =<< whnf t
export covering %inline
2023-04-15 09:13:01 -04:00
expectTYPE : Term 0 n -> Eff fs Universe
2023-05-01 21:06:25 -04:00
expectTYPE = expect ExpectedTYPE `(TYPE {l, _}) `(l)
export covering %inline
2023-04-15 09:13:01 -04:00
expectPi : Term 0 n -> Eff fs (Qty, Term 0 n, ScopeTerm 0 n)
2023-05-01 21:06:25 -04:00
expectPi = expect ExpectedPi `(Pi {qty, arg, res, _}) `((qty, arg, res))
export covering %inline
2023-04-15 09:13:01 -04:00
expectSig : Term 0 n -> Eff fs (Term 0 n, ScopeTerm 0 n)
2023-05-01 21:06:25 -04:00
expectSig = expect ExpectedSig `(Sig {fst, snd, _}) `((fst, snd))
export covering %inline
2023-04-15 09:13:01 -04:00
expectEnum : Term 0 n -> Eff fs (SortedSet TagVal)
2023-05-01 21:06:25 -04:00
expectEnum = expect ExpectedEnum `(Enum {cases, _}) `(cases)
export covering %inline
2023-04-15 09:13:01 -04:00
expectEq : Term 0 n -> Eff fs (DScopeTerm 0 n, Term 0 n, Term 0 n)
2023-05-01 21:06:25 -04:00
expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r))
2023-03-26 08:40:54 -04:00
export covering %inline
2023-11-02 13:14:22 -04:00
expectNAT : Term 0 n -> Eff fs ()
expectNAT = expect ExpectedNAT `(NAT {}) `(())
2023-03-31 13:11:35 -04:00
export covering %inline
expectSTRING : Term 0 n -> Eff fs ()
expectSTRING = expect ExpectedSTRING `(STRING {}) `(())
2023-03-31 13:11:35 -04:00
export covering %inline
2023-04-15 09:13:01 -04:00
expectBOX : Term 0 n -> Eff fs (Qty, Term 0 n)
2023-05-01 21:06:25 -04:00
expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty))