quox/lib/Quox/Typing.idr

199 lines
5.8 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
import public Quox.Reduce
2021-12-23 13:05:50 -05:00
2023-03-31 13:23:30 -04:00
import Control.Eff
%default total
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-04-01 13:16:43 -04:00
lookupFree' : Has ErrorEff fs => Definitions -> Name -> Eff fs Definition
2023-02-10 15:40:44 -05:00
lookupFree' defs x =
case lookup x defs of
Just d => pure d
2023-03-31 13:23:30 -04:00
Nothing => throw $ NotInScope x
2023-02-10 15:40:44 -05:00
2023-02-12 15:30:08 -05:00
public export
2023-04-01 13:16:43 -04:00
substCasePairRet : Term d n -> ScopeTerm d n -> Term d (2 + n)
2023-02-10 15:40:44 -05:00
substCasePairRet dty retty =
2023-03-31 13:26:55 -04:00
let arg = Pair (BVT 1) (BVT 0) :# (dty // fromNat 2) 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-04-01 13:16:43 -04:00
substCaseSuccRet : ScopeTerm d n -> Term d (2 + n)
2023-03-31 13:26:55 -04:00
substCaseSuccRet retty = retty.term // (Succ (BVT 1) :# Nat ::: shift 2)
2023-03-26 08:40:54 -04:00
2023-03-31 13:11:35 -04:00
public export
2023-04-01 13:16:43 -04:00
substCaseBoxRet : Term d n -> ScopeTerm d n -> Term d (S n)
2023-03-31 13:11:35 -04:00
substCaseBoxRet dty retty =
retty.term // (Box (BVT 0) :# weakT dty ::: shift 1)
2023-02-11 12:15:50 -05:00
2023-03-31 13:23:30 -04:00
2023-04-01 13:16:43 -04:00
parameters (defs : Definitions) {auto _ : Has ErrorEff fs}
export covering %inline
2023-03-13 14:39:29 -04:00
whnfT : {0 isRedex : RedexTest tm} -> Whnf tm isRedex WhnfError =>
2023-04-01 13:16:43 -04:00
{d, n : Nat} -> tm d n -> Eff fs (NonRedex tm d n defs)
2023-03-31 13:23:30 -04:00
whnfT = either (throw . WhnfError) pure . whnf defs
2023-04-01 13:16:43 -04:00
parameters {d2, n : Nat} (ctx : Lazy (TyContext d1 n))
(th : Lazy (DSubst d2 d1))
export covering %inline
2023-04-01 13:16:43 -04:00
expectTYPE_ : Term d2 n -> Eff fs Universe
expectTYPE_ s = case fst !(whnfT s) of
2023-02-11 12:15:50 -05:00
TYPE l => pure l
2023-03-31 13:23:30 -04:00
_ => throw $ ExpectedTYPE ctx (s // th)
2023-02-11 12:15:50 -05:00
export covering %inline
2023-04-01 13:16:43 -04:00
expectPi_ : Term d2 n -> Eff fs (Qty, Term d2 n, ScopeTerm d2 n)
expectPi_ s = case fst !(whnfT s) of
2023-02-11 12:15:50 -05:00
Pi {qty, arg, res, _} => pure (qty, arg, res)
2023-03-31 13:23:30 -04:00
_ => throw $ ExpectedPi ctx (s // th)
2023-02-11 12:15:50 -05:00
export covering %inline
2023-04-01 13:16:43 -04:00
expectSig_ : Term d2 n -> Eff fs (Term d2 n, ScopeTerm d2 n)
expectSig_ s = case fst !(whnfT s) of
2023-02-11 12:15:50 -05:00
Sig {fst, snd, _} => pure (fst, snd)
2023-03-31 13:23:30 -04:00
_ => throw $ ExpectedSig ctx (s // th)
2023-02-11 12:15:50 -05:00
export covering %inline
2023-04-01 13:16:43 -04:00
expectEnum_ : Term d2 n -> Eff fs (SortedSet TagVal)
expectEnum_ s = case fst !(whnfT s) of
Enum tags => pure tags
2023-03-31 13:23:30 -04:00
_ => throw $ ExpectedEnum ctx (s // th)
export covering %inline
2023-04-01 13:16:43 -04:00
expectEq_ : Term d2 n ->
Eff fs (DScopeTerm d2 n, Term d2 n, Term d2 n)
expectEq_ s = case fst !(whnfT s) of
2023-02-11 12:15:50 -05:00
Eq {ty, l, r, _} => pure (ty, l, r)
2023-03-31 13:23:30 -04:00
_ => throw $ ExpectedEq ctx (s // th)
2023-03-26 08:40:54 -04:00
export covering %inline
2023-04-01 13:16:43 -04:00
expectNat_ : Term d2 n -> Eff fs ()
2023-03-26 08:40:54 -04:00
expectNat_ s = case fst !(whnfT s) of
Nat => pure ()
2023-03-31 13:23:30 -04:00
_ => throw $ ExpectedNat ctx (s // th)
2023-03-26 08:40:54 -04:00
2023-03-31 13:11:35 -04:00
export covering %inline
2023-04-01 13:16:43 -04:00
expectBOX_ : Term d2 n -> Eff fs (Qty, Term d2 n)
2023-03-31 13:11:35 -04:00
expectBOX_ s = case fst !(whnfT s) of
BOX q a => pure (q, a)
2023-03-31 13:23:30 -04:00
_ => throw $ ExpectedBOX ctx (s // th)
2023-03-31 13:11:35 -04:00
-- [fixme] refactor this stuff
2023-04-01 13:16:43 -04:00
parameters (ctx : TyContext d n)
export covering %inline
2023-04-01 13:16:43 -04:00
expectTYPE : Term d n -> Eff fs Universe
expectTYPE =
let Val d = ctx.dimLen; Val n = ctx.termLen in
expectTYPE_ ctx id
export covering %inline
2023-04-01 13:16:43 -04:00
expectPi : Term d n -> Eff fs (Qty, Term d n, ScopeTerm d n)
expectPi =
let Val d = ctx.dimLen; Val n = ctx.termLen in
expectPi_ ctx id
export covering %inline
2023-04-01 13:16:43 -04:00
expectSig : Term d n -> Eff fs (Term d n, ScopeTerm d n)
expectSig =
let Val d = ctx.dimLen; Val n = ctx.termLen in
expectSig_ ctx id
export covering %inline
2023-04-01 13:16:43 -04:00
expectEnum : Term d n -> Eff fs (SortedSet TagVal)
expectEnum =
let Val d = ctx.dimLen; Val n = ctx.termLen in
expectEnum_ ctx id
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)
expectEq =
let Val d = ctx.dimLen; Val n = ctx.termLen in
expectEq_ ctx id
2023-03-26 08:40:54 -04:00
export covering %inline
2023-04-01 13:16:43 -04:00
expectNat : Term d n -> Eff fs ()
2023-03-26 08:40:54 -04:00
expectNat =
let Val d = ctx.dimLen; Val n = ctx.termLen in
expectNat_ ctx id
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-03-31 13:11:35 -04:00
expectBOX =
let Val d = ctx.dimLen; Val n = ctx.termLen in
expectBOX_ ctx id
2023-04-01 13:16:43 -04:00
parameters (ctx : EqContext n)
export covering %inline
2023-04-01 13:16:43 -04:00
expectTYPEE : Term 0 n -> Eff fs Universe
expectTYPEE t =
let Val n = ctx.termLen in
expectTYPE_ (toTyContext ctx) (shift0 ctx.dimLen) t
export covering %inline
2023-04-01 13:16:43 -04:00
expectPiE : Term 0 n -> Eff fs (Qty, Term 0 n, ScopeTerm 0 n)
expectPiE t =
let Val n = ctx.termLen in
expectPi_ (toTyContext ctx) (shift0 ctx.dimLen) t
export covering %inline
2023-04-01 13:16:43 -04:00
expectSigE : Term 0 n -> Eff fs (Term 0 n, ScopeTerm 0 n)
expectSigE t =
let Val n = ctx.termLen in
expectSig_ (toTyContext ctx) (shift0 ctx.dimLen) t
export covering %inline
2023-04-01 13:16:43 -04:00
expectEnumE : Term 0 n -> Eff fs (SortedSet TagVal)
expectEnumE t =
let Val n = ctx.termLen in
expectEnum_ (toTyContext ctx) (shift0 ctx.dimLen) t
export covering %inline
2023-04-01 13:16:43 -04:00
expectEqE : Term 0 n -> Eff fs (DScopeTerm 0 n, Term 0 n, Term 0 n)
expectEqE t =
let Val n = ctx.termLen in
expectEq_ (toTyContext ctx) (shift0 ctx.dimLen) t
2023-03-26 08:40:54 -04:00
export covering %inline
2023-04-01 13:16:43 -04:00
expectNatE : Term 0 n -> Eff fs ()
2023-03-26 08:40:54 -04:00
expectNatE t =
let Val n = ctx.termLen in
expectNat_ (toTyContext ctx) (shift0 ctx.dimLen) t
2023-03-31 13:11:35 -04:00
export covering %inline
2023-04-01 13:16:43 -04:00
expectBOXE : Term 0 n -> Eff fs (Qty, Term 0 n)
2023-03-31 13:11:35 -04:00
expectBOXE t =
let Val n = ctx.termLen in
expectBOX_ (toTyContext ctx) (shift0 ctx.dimLen) t