quox/lib/Quox/Typing/Context.idr

module Quox.Typing.Context

import Quox.Syntax
import Quox.Context
import Quox.Pretty
import public Data.Singleton
import Derive.Prelude

%default total
%language ElabReflection


public export
QContext : Nat -> Type
QContext = Context' Qty

public export
record LocalVar d n where
  constructor MkLocal
  type : Term d n
  term : Maybe (Term d n) -- if from a `let`
%runElab deriveIndexed "LocalVar" [Show]

export
CanShift (LocalVar d) where
  l // by = {type $= (// by), term $= map (// by)} l

namespace LocalVar
  subD : DSubst d1 d2 -> LocalVar d1 n -> LocalVar d2 n
  subD th = {type $= (// th), term $= map (// th)}

  weakD : LocalVar d n -> LocalVar (S d) n
  weakD = subD $ shift 1

public export
TContext : TermLike
TContext d = Context (\n => LocalVar d n)

public export
QOutput : Nat -> Type
QOutput = Context' Qty

public export
DimAssign : Nat -> Type
DimAssign = Context' DimConst


public export
record TyContext d n where
  constructor MkTyContext
  {auto dimLen  : Singleton d}
  {auto termLen : Singleton n}
  dctx   : DimEq d
  dnames : BContext d
  tctx   : TContext d n
  tnames : BContext n -- only used for printing
  qtys   : QContext n -- only used for printing
%name TyContext ctx
%runElab deriveIndexed "TyContext" [Show]


public export
record EqContext n where
  constructor MkEqContext
  {dimLen : Nat}
  {auto termLen : Singleton n}
  dassign : DimAssign dimLen -- only used for printing
  dnames  : BContext dimLen -- only used for printing
  tctx    : TContext 0 n
  tnames  : BContext n -- only used for printing
  qtys    : QContext n -- only used for printing
%name EqContext ctx
%runElab deriveIndexed "EqContext" [Show]


public export
record WhnfContext d n where
  constructor MkWhnfContext
  {auto dimLen  : Singleton d}
  {auto termLen : Singleton n}
  dnames : BContext d
  tnames : BContext n
  tctx   : TContext d n
%name WhnfContext ctx
%runElab deriveIndexed "WhnfContext" [Show]

namespace TContext
  export %inline
  zeroFor : Context tm n -> QOutput n
  zeroFor ctx = Zero <$ ctx

public export
extendLen : Telescope a n1 n2 -> Singleton n1 -> Singleton n2
extendLen [<]        x = x
extendLen (tel :< _) x = [|S $ extendLen tel x|]


public export
CtxExtension : Nat -> Nat -> Nat -> Type
CtxExtension d = Telescope ((Qty, BindName,) . Term d)

public export
CtxExtension0 : Nat -> Nat -> Nat -> Type
CtxExtension0 d = Telescope ((BindName,) . Term d)

public export
CtxExtensionLet : Nat -> Nat -> Nat -> Type
CtxExtensionLet d = Telescope ((Qty, BindName,) . LocalVar d)

public export
CtxExtensionLet0 : Nat -> Nat -> Nat -> Type
CtxExtensionLet0 d = Telescope ((BindName,) . LocalVar d)

namespace TyContext
  public export %inline
  empty : TyContext 0 0
  empty =
    MkTyContext {dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]}

  public export %inline
  null : TyContext d n -> Bool
  null ctx = null ctx.dnames && null ctx.tnames

  export %inline
  extendTyLetN : CtxExtensionLet d n1 n2 -> TyContext d n1 -> TyContext d n2
  extendTyLetN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) =
    let (qs, xs, ls) = unzip3 xss in
    MkTyContext {
      dctx, dnames,
      termLen = extendLen xss termLen,
      tctx    = tctx . ls,
      tnames  = tnames . xs,
      qtys    = qtys . qs
    }

  export %inline
  extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2
  extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, MkLocal s Nothing))

  export %inline
  extendTyLetN0 : CtxExtensionLet0 d n1 n2 -> TyContext d n1 -> TyContext d n2
  extendTyLetN0 xss = extendTyLetN (map (Zero,) xss)

  export %inline
  extendTyN0 : CtxExtension0 d n1 n2 -> TyContext d n1 -> TyContext d n2
  extendTyN0 xss = extendTyN (map (Zero,) xss)

  export %inline
  extendTyLet : Qty -> BindName -> Term d n -> Term d n ->
                TyContext d n -> TyContext d (S n)
  extendTyLet q x s e = extendTyLetN [< (q, x, MkLocal s (Just e))]

  export %inline
  extendTy : Qty -> BindName -> Term d n -> TyContext d n -> TyContext d (S n)
  extendTy q x s = extendTyN [< (q, x, s)]

  export %inline
  extendTy0 : BindName -> Term d n -> TyContext d n -> TyContext d (S n)
  extendTy0 = extendTy Zero

  export %inline
  extendDim : BindName -> TyContext d n -> TyContext (S d) n
  extendDim x (MkTyContext {dimLen, dctx, dnames, tctx, tnames, qtys}) =
    MkTyContext {
      dctx   = dctx :<? Nothing,
      dnames = dnames :< x,
      dimLen = [|S dimLen|],
      tctx   = map weakD tctx,
      tnames, qtys
    }

  export %inline
  eqDim : Dim d -> Dim d -> TyContext d n -> TyContext d n
  eqDim p q = {dctx $= set p q, dimLen $= id, termLen $= id}

  export
  toWhnfContext : TyContext d n -> WhnfContext d n
  toWhnfContext (MkTyContext {dnames, tnames, tctx, _}) =
    MkWhnfContext {dnames, tnames, tctx}


namespace QOutput
  export %inline
  (+) : QOutput n -> QOutput n -> QOutput n
  (+) = zipWith (+)

  export %inline
  (*) : Qty -> QOutput n -> QOutput n
  (*) pi = map (pi *)

  export %inline
  zeroFor : TyContext _ n -> QOutput n
  zeroFor ctx = zeroFor ctx.tctx


export
makeDAssign : DSubst d 0 -> DimAssign d
makeDAssign (Shift SZ)     = [<]
makeDAssign (K e _ ::: th) = makeDAssign th :< e

export
makeEqContext' : {d : Nat} -> TyContext d n -> DSubst d 0 -> EqContext n
makeEqContext' ctx th = MkEqContext {
  termLen = ctx.termLen,
  dassign = makeDAssign th,
  dnames  = ctx.dnames,
  tctx    = map (subD th) ctx.tctx,
  tnames  = ctx.tnames,
  qtys    = ctx.qtys
}

export
makeEqContext : TyContext d n -> DSubst d 0 -> EqContext n
makeEqContext ctx@(MkTyContext {dnames, _}) th =
  let Val d = lengthPrf0 dnames in makeEqContext' ctx th

namespace EqContext
  public export %inline
  empty : EqContext 0
  empty = MkEqContext {
    dassign = [<], dnames = [<], tctx = [<], tnames = [<], qtys = [<]
  }

  public export %inline
  null : EqContext n -> Bool
  null ctx = null ctx.dnames && null ctx.tnames

  export %inline
  extendTyLetN : CtxExtensionLet 0 n1 n2 -> EqContext n1 -> EqContext n2
  extendTyLetN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) =
    let (qs, xs, ls) = unzip3 xss in
    MkEqContext {
      termLen = extendLen xss termLen,
      tctx    = tctx . ls,
      tnames  = tnames . xs,
      qtys    = qtys . qs,
      dassign, dnames
    }

  export %inline
  extendTyN : CtxExtension 0 n1 n2 -> EqContext n1 -> EqContext n2
  extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, MkLocal s Nothing))

  export %inline
  extendTyLetN0 : CtxExtensionLet0 0 n1 n2 -> EqContext n1 -> EqContext n2
  extendTyLetN0 xss = extendTyLetN (map (Zero,) xss)

  export %inline
  extendTyN0 : CtxExtension0 0 n1 n2 -> EqContext n1 -> EqContext n2
  extendTyN0 xss = extendTyN (map (Zero,) xss)

  export %inline
  extendTyLet : Qty -> BindName -> Term 0 n -> Term 0 n ->
                EqContext n -> EqContext (S n)
  extendTyLet q x s e = extendTyLetN [< (q, x, MkLocal s (Just e))]

  export %inline
  extendTy : Qty -> BindName -> Term 0 n -> EqContext n -> EqContext (S n)
  extendTy q x s = extendTyN [< (q, x, s)]

  export %inline
  extendTy0 : BindName -> Term 0 n -> EqContext n -> EqContext (S n)
  extendTy0 = extendTy Zero

  export %inline
  extendDim : BindName -> DimConst -> EqContext n -> EqContext n
  extendDim x e (MkEqContext {dassign, dnames, tctx, tnames, qtys}) =
    MkEqContext {dassign = dassign :< e, dnames = dnames :< x,
                 tctx, tnames, qtys}

  export
  toTyContext : (e : EqContext n) -> TyContext e.dimLen n
  toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) =
    MkTyContext {
      dctx = fromGround dassign,
      tctx = map (subD $ shift0 dimLen) tctx,
      dnames, tnames, qtys
    }

  export
  toWhnfContext : (ectx : EqContext n) -> WhnfContext 0 n
  toWhnfContext (MkEqContext {tnames, tctx, _}) =
    MkWhnfContext {dnames = [<], tnames, tctx}

  export
  injElim : WhnfContext d n -> Elim 0 0 -> Elim d n
  injElim ctx e =
    let Val d = ctx.dimLen; Val n = ctx.termLen in
    e // shift0 d // shift0 n

namespace WhnfContext
  public export %inline
  empty : WhnfContext 0 0
  empty = MkWhnfContext [<] [<] [<]

  export
  extendDimN : {s : Nat} -> BContext s -> WhnfContext d n ->
               WhnfContext (s + d) n
  extendDimN ns (MkWhnfContext {dnames, tnames, tctx, dimLen}) =
    MkWhnfContext {
      dimLen = [|Val s + dimLen|],
      dnames = dnames ++ toSnocVect' ns,
      tctx   = map (subD $ shift s) tctx,
      tnames
    }

  export
  extendDim : BindName -> WhnfContext d n -> WhnfContext (S d) n
  extendDim i = extendDimN [< i]


private
prettyTContextElt : {opts : _} ->
                    BContext d -> BContext n ->
                    Qty -> BindName -> LocalVar d n -> Eff Pretty (Doc opts)
prettyTContextElt dnames tnames q x s = do
  q  <- prettyQty q;   dot <- dotD
  x  <- prettyTBind x; colon <- colonD
  ty <- withPrec Outer $ prettyTerm dnames tnames s.type; eq <- cstD
  tm <- traverse (withPrec Outer . prettyTerm dnames tnames) s.term
  d  <- askAt INDENT
  let qx = hcat [q, dot, x]
  pure $ case tm of
    Nothing =>
      ifMultiline (hsep [qx, colon, ty]) (vsep [qx, indent d $ colon <++> ty])
    Just tm =>
      ifMultiline (hsep [qx, colon, ty, eq, tm])
                  (vsep [qx, indent d $ colon <++> ty, indent d $ eq <++> tm])

private
prettyTContext' : {opts : _} ->
                  BContext d -> QContext n -> BContext n ->
                  TContext d n -> Eff Pretty (SnocList (Doc opts))
prettyTContext' _ [<] [<] [<] = pure [<]
prettyTContext' dnames (qtys :< q) (tnames :< x) (tys :< t) =
  [|prettyTContext' dnames qtys tnames tys :<
    prettyTContextElt dnames tnames q x t|]

export
prettyTContext : {opts : _} ->
                 BContext d -> QContext n -> BContext n ->
                 TContext d n -> Eff Pretty (Doc opts)
prettyTContext dnames qtys tnames tys =
  separateTight !commaD <$> prettyTContext' dnames qtys tnames tys

export
prettyTyContext : {opts : _} -> TyContext d n -> Eff Pretty (Doc opts)
prettyTyContext (MkTyContext dctx dnames tctx tnames qtys) =
  case dctx of
    C [<] => prettyTContext dnames qtys tnames tctx
    _     => pure $
      sep [!(prettyDimEq dnames dctx) <++> !pipeD,
           !(prettyTContext dnames qtys tnames tctx)]

export
prettyEqContext : {opts : _} -> EqContext n -> Eff Pretty (Doc opts)
prettyEqContext ctx = prettyTyContext $ toTyContext ctx