158 lines
3.4 KiB
Idris
158 lines
3.4 KiB
Idris
module Quox.Typing
|
|
|
|
import public Quox.Syntax
|
|
import public Quox.Context
|
|
import public Quox.Definition
|
|
|
|
import Data.Nat
|
|
import public Data.SortedMap
|
|
import Control.Monad.Either
|
|
import Control.Monad.Reader
|
|
import Control.Monad.State
|
|
import Generics.Derive
|
|
|
|
%hide TT.Name
|
|
%default total
|
|
%language ElabReflection
|
|
|
|
%default total
|
|
|
|
|
|
public export
|
|
data DContext : Nat -> Type where
|
|
DNil : DContext 0
|
|
DBind : DContext d -> DContext (S d)
|
|
DEq : Dim d -> Dim d -> DContext d -> DContext d
|
|
|
|
public export
|
|
TContext : Type -> Nat -> Nat -> Type
|
|
TContext q d = Context (Term q d)
|
|
|
|
public export
|
|
QContext : Type -> Nat -> Type
|
|
QContext = Context'
|
|
|
|
public export
|
|
QOutput : Type -> Nat -> Type
|
|
QOutput = QContext
|
|
|
|
|
|
public export
|
|
record TyContext q d n where
|
|
constructor MkTyContext
|
|
dctx : DContext d
|
|
tctx : TContext q d n
|
|
qctx : QContext q n
|
|
|
|
%name TyContext ctx
|
|
|
|
|
|
namespace TContext
|
|
export
|
|
pushD : TContext q d n -> TContext q (S d) n
|
|
pushD tel = map (/// shift 1) tel
|
|
|
|
export
|
|
zeroed : IsQty q => TyContext q d n -> TyContext q d n
|
|
zeroed = {qctx $= map (const zero)}
|
|
|
|
|
|
namespace TyContext
|
|
export
|
|
extendTyN : Telescope (\n => (Term q d n, q)) from to ->
|
|
TyContext q d from -> TyContext q d to
|
|
extendTyN ss = {tctx $= (. map fst ss), qctx $= (. map snd ss)}
|
|
|
|
export
|
|
extendTy : Term q d n -> q -> TyContext q d n -> TyContext q d (S n)
|
|
extendTy s rho = extendTyN [< (s, rho)]
|
|
|
|
export
|
|
extendDim : TyContext q d n -> TyContext q (S d) n
|
|
extendDim = {dctx $= DBind, tctx $= pushD}
|
|
|
|
export
|
|
eqDim : Dim d -> Dim d -> TyContext q d n -> TyContext q d n
|
|
eqDim p q = {dctx $= DEq p q}
|
|
|
|
|
|
namespace QOutput
|
|
parameters {auto _ : IsQty q}
|
|
export
|
|
(+) : QOutput q n -> QOutput q n -> QOutput q n
|
|
(+) = zipWith (+)
|
|
|
|
export
|
|
(*) : q -> QOutput q n -> QOutput q n
|
|
(*) pi = map (pi *)
|
|
|
|
export
|
|
zero : {n : Nat} -> QOutput q n
|
|
zero = pure zero
|
|
|
|
export
|
|
zeroFor : TyContext q _ n -> QOutput q n
|
|
zeroFor ctx = zero <$ ctx.tctx
|
|
|
|
|
|
public export
|
|
CheckResult : Type -> Nat -> Type
|
|
CheckResult = QOutput
|
|
|
|
public export
|
|
record InferResult q d n where
|
|
constructor InfRes
|
|
type : Term q d n
|
|
qout : QOutput q n
|
|
|
|
|
|
public export
|
|
data EqMode = Equal | Sub
|
|
%runElab derive "EqMode" [Generic, Meta, Eq, Ord, DecEq, Show]
|
|
|
|
|
|
public export
|
|
data Error q
|
|
= ExpectedTYPE (Term q d n)
|
|
| ExpectedPi (Term q d n)
|
|
| ExpectedSig (Term q d n)
|
|
| ExpectedEq (Term q d n)
|
|
| BadUniverse Universe Universe
|
|
|
|
| ClashT EqMode (Term q d n) (Term q d n)
|
|
| ClashU EqMode Universe Universe
|
|
| ClashQ q q
|
|
| ClashD (Dim d) (Dim d)
|
|
| NotInScope Name
|
|
|
|
public export
|
|
0 HasErr : Type -> (Type -> Type) -> Type
|
|
HasErr q = MonadError (Error q)
|
|
|
|
export %inline
|
|
ucmp : EqMode -> Universe -> Universe -> Bool
|
|
ucmp Sub = (<=)
|
|
ucmp Equal = (==)
|
|
|
|
|
|
parameters {auto _ : HasErr q m}
|
|
export %inline
|
|
expect : Eq a => (a -> a -> Error q) -> (a -> a -> Bool) -> a -> a -> m ()
|
|
expect err cmp x y = unless (x `cmp` y) $ throwError $ err x y
|
|
|
|
export %inline
|
|
expectEqualQ : Eq q => q -> q -> m ()
|
|
expectEqualQ = expect ClashQ (==)
|
|
|
|
export %inline
|
|
expectCompatQ : IsQty q => q -> q -> m ()
|
|
expectCompatQ = expect ClashQ $ \pi, rh => isYes $ pi `compat` rh
|
|
|
|
export %inline
|
|
expectModeU : EqMode -> Universe -> Universe -> m ()
|
|
expectModeU mode = expect (ClashU mode) $ ucmp mode
|
|
|
|
export %inline
|
|
expectEqualD : Dim d -> Dim d -> m ()
|
|
expectEqualD = expect ClashD (==)
|