quox/lib/Quox/Typing.idr

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


namespace TyContext
  export
  extendTy : Term q d n -> q -> TyContext q d n -> TyContext q d (S n)
  extendTy s rho = {tctx $= (:< s), qctx $= (:< 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


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)
| BadUniverse  Universe Universe

| ClashT EqMode (Term q d n) (Term q d n)
| ClashU EqMode Universe     Universe
| ClashQ        q            q
| NotInScope    Name

public export
0 HasErr : Type -> (Type -> Type) -> Type
HasErr q = MonadError (Error q)