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 %hide SOP.from %hide SOP.to %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 -- first arg of ClashT is the type | ClashT EqMode (Term q d n) (Term q d n) (Term q d n) | ClashE EqMode (Elim q d n) (Elim q d n) | ClashU EqMode Universe Universe | ClashQ q q | ClashD (Dim d) (Dim d) | NotInScope Name | NotType (Term q d n) | WrongType (Term q d n) (Term q d n) (Term q d n) 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 (==) export lookupFree' : HasErr q m => Definitions' q g -> Name -> m (Definition' q g) lookupFree' defs x = case lookup x defs of Just d => pure d Nothing => throwError $ NotInScope x export substCasePairRet : Term q d n -> ScopeTerm q d n -> Term q d (2 + n) substCasePairRet dty retty = let arg = Pair (BVT 0) (BVT 1) :# (dty // fromNat 2) in retty.term // (arg ::: shift 2)