quox/lib/Quox/Typing.idr

module Quox.Typing

import public Quox.Typing.Context as Typing
import public Quox.Typing.EqMode as Typing
import public Quox.Typing.Error as Typing

import public Quox.Syntax
import public Quox.Definition
import public Quox.Reduce

import Control.Eff

%default total


public export
CheckResult' : Nat -> Type
CheckResult' = QOutput

public export
CheckResult : DimEq d -> Nat -> Type
CheckResult eqs n = IfConsistent eqs $ CheckResult' n

public export
record InferResult' d n where
  constructor InfRes
  type : Term d n
  qout : QOutput n

public export
InferResult : DimEq d -> TermLike
InferResult eqs d n = IfConsistent eqs $ InferResult' d n


export
lookupFree' : Has ErrorEff fs => Definitions -> Name -> Eff fs Definition
lookupFree' defs x =
  case lookup x defs of
    Just d  => pure d
    Nothing => throw $ NotInScope x


public export
substCasePairRet : Term d n -> ScopeTerm d n -> Term d (2 + n)
substCasePairRet dty retty =
  let arg = Pair (BVT 1) (BVT 0) :# (dty // fromNat 2) in
  retty.term // (arg ::: shift 2)

public export
substCaseSuccRet : ScopeTerm d n -> Term d (2 + n)
substCaseSuccRet retty = retty.term // (Succ (BVT 1) :# Nat ::: shift 2)

public export
substCaseBoxRet : Term d n -> ScopeTerm d n -> Term d (S n)
substCaseBoxRet dty retty =
  retty.term // (Box (BVT 0) :# weakT dty ::: shift 1)


parameters (defs : Definitions) {auto _ : Has ErrorEff fs}
  export covering %inline
  whnfT : {0 isRedex : RedexTest tm} -> Whnf tm isRedex WhnfError =>
          {d, n : Nat} -> tm d n -> Eff fs (NonRedex tm d n defs)
  whnfT = either (throw . WhnfError) pure . whnf defs

  parameters {d2, n : Nat} (ctx : Lazy (TyContext d1 n))
             (th : Lazy (DSubst d2 d1))
    export covering %inline
    expectTYPE_ : Term d2 n -> Eff fs Universe
    expectTYPE_ s = case fst !(whnfT s) of
      TYPE l => pure l
      _      => throw $ ExpectedTYPE ctx (s // th)

    export covering %inline
    expectPi_ : Term d2 n -> Eff fs (Qty, Term d2 n, ScopeTerm d2 n)
    expectPi_ s = case fst !(whnfT s) of
      Pi {qty, arg, res, _} => pure (qty, arg, res)
      _                     => throw $ ExpectedPi ctx (s // th)

    export covering %inline
    expectSig_ : Term d2 n -> Eff fs (Term d2 n, ScopeTerm d2 n)
    expectSig_ s = case fst !(whnfT s) of
      Sig {fst, snd, _} => pure (fst, snd)
      _                 => throw $ ExpectedSig ctx (s // th)

    export covering %inline
    expectEnum_ : Term d2 n -> Eff fs (SortedSet TagVal)
    expectEnum_ s = case fst !(whnfT s) of
      Enum tags => pure tags
      _         => throw $ ExpectedEnum ctx (s // th)

    export covering %inline
    expectEq_ : Term d2 n ->
                Eff fs (DScopeTerm d2 n, Term d2 n, Term d2 n)
    expectEq_ s = case fst !(whnfT s) of
      Eq {ty, l, r, _} => pure (ty, l, r)
      _                => throw $ ExpectedEq ctx (s // th)

    export covering %inline
    expectNat_ : Term d2 n -> Eff fs ()
    expectNat_ s = case fst !(whnfT s) of
      Nat => pure ()
      _   => throw $ ExpectedNat ctx (s // th)

    export covering %inline
    expectBOX_ : Term d2 n -> Eff fs (Qty, Term d2 n)
    expectBOX_ s = case fst !(whnfT s) of
      BOX q a => pure (q, a)
      _       => throw $ ExpectedBOX ctx (s // th)


  -- [fixme] refactor this stuff

  parameters (ctx : TyContext d n)
    export covering %inline
    expectTYPE : Term d n -> Eff fs Universe
    expectTYPE =
      let Val d = ctx.dimLen; Val n = ctx.termLen in
      expectTYPE_ ctx id

    export covering %inline
    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
    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
    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
    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

    export covering %inline
    expectNat : Term d n -> Eff fs ()
    expectNat =
      let Val d = ctx.dimLen; Val n = ctx.termLen in
      expectNat_ ctx id

    export covering %inline
    expectBOX : Term d n -> Eff fs (Qty, Term d n)
    expectBOX =
      let Val d = ctx.dimLen; Val n = ctx.termLen in
      expectBOX_ ctx id


  parameters (ctx : EqContext n)
    export covering %inline
    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
    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
    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
    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
    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

    export covering %inline
    expectNatE : Term 0 n -> Eff fs ()
    expectNatE t =
      let Val n = ctx.termLen in
      expectNat_ (toTyContext ctx) (shift0 ctx.dimLen) t

    export covering %inline
    expectBOXE : Term 0 n -> Eff fs (Qty, Term 0 n)
    expectBOXE t =
      let Val n = ctx.termLen in
      expectBOX_ (toTyContext ctx) (shift0 ctx.dimLen) t