quox/lib/Quox/Syntax/Term/Base.idr

module Quox.Syntax.Term.Base

import public Quox.Var
import public Quox.Scoped
import public Quox.Syntax.Shift
import public Quox.Syntax.Subst
import public Quox.Syntax.Qty
import public Quox.Syntax.Dim
import public Quox.Syntax.Term.TyConKind
import public Quox.Name
import public Quox.Loc
import public Quox.Context

import Quox.Pretty

import public Data.DPair
import Data.List
import Data.Maybe
import Data.Nat
import public Data.So
import Data.String
import public Data.SortedMap
import public Data.SortedMap.Dependent
import public Data.SortedSet
import Derive.Prelude

%default total
%language ElabReflection

%hide TT.Name


public export
TermLike : Type
TermLike = (q, d, n : Nat) -> Type

public export
TSubstLike : Type
TSubstLike = (q, d, n1, n2 : Nat) -> Type

public export
Universe : Type
Universe = Nat

public export
TagVal : Type
TagVal = String


mutual
  public export
  TSubst : TSubstLike
  TSubst q d = Subst $ \n => Elim q d n

  ||| first argument `d` is dimension scope size;
  ||| second `n` is term scope size
  public export
  data Term : (q, d, n : Nat) -> Type where
    ||| type of types
    TYPE : (l : Universe) -> (loc : Loc) -> Term q d n

    ||| IO state token. this is a builtin because otherwise #[main] being a
    ||| builtin makes no sense
    IOState : (loc : Loc) -> Term q d n

    ||| function type
    Pi  : (qty : Qty q) -> (arg : Term q d n) ->
          (res : ScopeTerm q d n) -> (loc : Loc) -> Term q d n
    ||| function term
    Lam : (body : ScopeTerm q d n) -> (loc : Loc) -> Term q d n

    ||| pair type
    Sig : (fst : Term q d n) -> (snd : ScopeTerm q d n) -> (loc : Loc) ->
          Term q d n
    ||| pair value
    Pair : (fst, snd : Term q d n) -> (loc : Loc) -> Term q d n

    ||| enumeration type
    Enum : (cases : SortedSet TagVal) -> (loc : Loc) -> Term q d n
    ||| enumeration value
    Tag : (tag : TagVal) -> (loc : Loc) -> Term q d n

    ||| equality type
    Eq : (ty : DScopeTerm q d n) -> (l, r : Term q d n) -> (loc : Loc) ->
         Term q d n
    ||| equality term
    DLam : (body : DScopeTerm q d n) -> (loc : Loc) -> Term q d n

    ||| natural numbers (temporary until 𝐖 gets added)
    NAT : (loc : Loc) -> Term q d n
    Nat : (val : Nat) -> (loc : Loc) -> Term q d n
    Succ : (p : Term q d n) -> (loc : Loc) -> Term q d n

    ||| strings
    STRING : (loc : Loc) -> Term q d n
    Str    : (str : String) -> (loc : Loc) -> Term q d n

    ||| "box" (package a value up with a certain quantity)
    BOX : (qty : Qty q) -> (ty : Term q d n) -> (loc : Loc) -> Term q d n
    Box : (val : Term q d n) -> (loc : Loc) -> Term q d n

    Let : (qty : Qty q) -> (rhs : Elim q d n) ->
          (body : ScopeTerm q d n) -> (loc : Loc) -> Term q d n

    ||| elimination
    E : (e : Elim q d n) -> Term q d n

    ||| term closure/suspended substitution
    CloT  : WithSubst (Term q d) (Elim q d) n -> Term q d n
    ||| dimension closure/suspended substitution
    DCloT : WithSubst (\d => Term q d n) Dim d -> Term q d n
    ||| quantity closure/suspended substitution
    QCloT : WithSubstR (\q => Term q d n) Qty q -> Term q d n
  %name Term s, t, r

  ||| first argument `d` is dimension scope size, second `n` is term scope size
  public export
  data Elim : (q, d, n : Nat) -> Type where
    ||| free variable, possibly with a displacement (see @crude, or @mugen for a
    ||| more abstract and formalised take)
    |||
    ||| e.g. if f : ★₀ → ★₁, then f¹ : ★₁ → ★₂
    F : (x : Name) -> (u : Universe) -> (loc : Loc) -> Elim q d n
    ||| bound variable
    B : (i : Var n) -> (loc : Loc) -> Elim q d n

    ||| term application
    App : (fun : Elim q d n) -> (arg : Term q d n) -> (loc : Loc) -> Elim q d n

    ||| pair destruction
    |||
    ||| `CasePair 𝜋 𝑒 ([𝑟], 𝐴) ([𝑥, 𝑦], 𝑡)` is
    ||| `𝐜𝐚𝐬𝐞 𝜋 · 𝑒 𝐫𝐞𝐭𝐮𝐫𝐧 𝑟 ⇒ 𝐴 𝐨𝐟 { (𝑥, 𝑦) ⇒ 𝑡 }`
    CasePair : (qty : Qty q) -> (pair : Elim q d n) ->
               (ret : ScopeTerm q d n) ->
               (body : ScopeTermN 2 q d n) ->
               (loc : Loc) ->
               Elim q d n

    ||| first element of a pair. only works in non-linear contexts.
    Fst : (pair : Elim q d n) -> (loc : Loc) -> Elim q d n

    ||| second element of a pair. only works in non-linear contexts.
    Snd : (pair : Elim q d n) -> (loc : Loc) -> Elim q d n

    ||| enum matching
    CaseEnum : (qty : Qty q) -> (tag : Elim q d n) ->
               (ret : ScopeTerm q d n) ->
               (arms : CaseEnumArms q d n) ->
               (loc : Loc) ->
               Elim q d n

    ||| nat matching
    CaseNat : (qty, qtyIH : Qty q) -> (nat : Elim q d n) ->
              (ret : ScopeTerm q d n) ->
              (zero : Term q d n) ->
              (succ : ScopeTermN 2 q d n) ->
              (loc : Loc) ->
              Elim q d n

    ||| unboxing
    CaseBox : (qty : Qty q) -> (box : Elim q d n) ->
              (ret : ScopeTerm q d n) ->
              (body : ScopeTerm q d n) ->
              (loc : Loc) ->
              Elim q d n

    ||| dim application
    DApp : (fun : Elim q d n) -> (arg : Dim d) -> (loc : Loc) -> Elim q d n

    ||| type-annotated term
    Ann : (tm, ty : Term q d n) -> (loc : Loc) -> Elim q d n

    ||| coerce a value along a type equality, or show its coherence
    ||| [@xtt; §2.1.1]
    Coe : (ty : DScopeTerm q d n) -> (p, p' : Dim d) ->
          (val : Term q d n) -> (loc : Loc) -> Elim q d n

    ||| "generalised composition" [@xtt; §2.1.2]
    Comp : (ty : Term q d n) -> (p, p' : Dim d) ->
           (val : Term q d n) -> (r : Dim d) ->
           (zero, one : DScopeTerm q d n) -> (loc : Loc) -> Elim q d n

    ||| match on types. needed for b.s. of coercions [@xtt; §2.2]
    TypeCase : (ty : Elim q d n) -> (ret : Term q d n) ->
               (arms : TypeCaseArms q d n) -> (def : Term q d n) ->
               (loc : Loc) ->
               Elim q d n

    ||| term closure/suspended substitution
    CloE  : WithSubst (Elim q d) (Elim q d) n -> Elim q d n
    ||| dimension closure/suspended substitution
    DCloE : WithSubst (\d => Elim q d n) Dim d -> Elim q d n
    ||| quantity closure/suspended substitution
    QCloE : WithSubstR (\q => Elim q d n) Qty q -> Elim q d n
  %name Elim e, f

  public export
  CaseEnumArms : TermLike
  CaseEnumArms q d n = SortedMap TagVal (Term q d n)

  public export
  TypeCaseArms : TermLike
  TypeCaseArms q d n = SortedDMap TyConKind (\k => TypeCaseArmBody k q d n)

  public export
  TypeCaseArm : TermLike
  TypeCaseArm q d n = (k ** TypeCaseArmBody k q d n)

  public export
  TypeCaseArmBody : TyConKind -> TermLike
  TypeCaseArmBody k = ScopeTermN (arity k)


  public export
  ScopeTermN, DScopeTermN : Nat -> TermLike
  ScopeTermN  s q d n = Scoped s (Term q d) n
  DScopeTermN s q d n = Scoped s (\d => Term q d n) d

  public export
  ScopeTerm, DScopeTerm : TermLike
  ScopeTerm  = ScopeTermN 1
  DScopeTerm = DScopeTermN 1

export %hint EqTerm : Eq (Term q d n)
export %hint EqElim : Eq (Elim q d n)
EqTerm = assert_total {a = Eq (Term q d n)} deriveEq
EqElim = assert_total {a = Eq (Elim q d n)} deriveEq

-- export %hint ShowTerm : {q, d, n : Nat} -> Show (Term q d n)
-- export %hint ShowElim : {q, d, n : Nat} -> Show (Elim q d n)
-- ShowTerm = assert_total {a = Show (Term q d n)} deriveShow
-- ShowElim = assert_total {a = Show (Elim q d n)} deriveShow


export
Located (Elim q d n) where
  (F _ _ loc).loc               = loc
  (B _ loc).loc                 = loc
  (App _ _ loc).loc             = loc
  (CasePair _ _ _ _ loc).loc    = loc
  (Fst _ loc).loc               = loc
  (Snd _ loc).loc               = loc
  (CaseEnum _ _ _ _ loc).loc    = loc
  (CaseNat _ _ _ _ _ _ loc).loc = loc
  (CaseBox _ _ _ _ loc).loc     = loc
  (DApp _ _ loc).loc            = loc
  (Ann _ _ loc).loc             = loc
  (Coe _ _ _ _ loc).loc         = loc
  (Comp _ _ _ _ _ _ _ loc).loc  = loc
  (TypeCase _ _ _ _ loc).loc    = loc
  (CloE (Sub e _)).loc          = e.loc
  (DCloE (Sub e _)).loc         = e.loc
  (QCloE (SubR e _)).loc        = e.loc

export
Located (Term q d n) where
  (TYPE _ loc).loc       = loc
  (IOState loc).loc      = loc
  (Pi _ _ _ loc).loc     = loc
  (Lam _ loc).loc        = loc
  (Sig _ _ loc).loc      = loc
  (Pair _ _ loc).loc     = loc
  (Enum _ loc).loc       = loc
  (Tag _ loc).loc        = loc
  (Eq _ _ _ loc).loc     = loc
  (DLam _ loc).loc       = loc
  (NAT loc).loc          = loc
  (Nat _ loc).loc        = loc
  (STRING loc).loc       = loc
  (Str _ loc).loc        = loc
  (Succ _ loc).loc       = loc
  (BOX _ _ loc).loc      = loc
  (Box _ loc).loc        = loc
  (Let _ _ _ loc).loc    = loc
  (E e).loc              = e.loc
  (CloT (Sub t _)).loc   = t.loc
  (DCloT (Sub t _)).loc  = t.loc
  (QCloT (SubR t _)).loc = t.loc

export
Located1 f => Located (ScopedBody s f n) where
  (Y t).loc = t.loc
  (N t).loc = t.loc

export
Located1 f => Located (Scoped s f n) where
  t.loc = t.body.loc


export
Relocatable (Elim q d n) where
  setLoc loc (F x u _) = F x u loc
  setLoc loc (B i _) = B i loc
  setLoc loc (App fun arg _) = App fun arg loc
  setLoc loc (CasePair qty pair ret body _) =
    CasePair qty pair ret body loc
  setLoc loc (Fst pair _) = Fst pair loc
  setLoc loc (Snd pair _) = Fst pair loc
  setLoc loc (CaseEnum qty tag ret arms _) =
    CaseEnum qty tag ret arms loc
  setLoc loc (CaseNat qty qtyIH nat ret zero succ _) =
    CaseNat qty qtyIH nat ret zero succ loc
  setLoc loc (CaseBox qty box ret body _) =
    CaseBox qty box ret body loc
  setLoc loc (DApp fun arg _) =
    DApp fun arg loc
  setLoc loc (Ann tm ty _) =
    Ann tm ty loc
  setLoc loc (Coe ty p q val _) =
    Coe ty p q val loc
  setLoc loc (Comp ty p q val r zero one _) =
    Comp ty p q val r zero one loc
  setLoc loc (TypeCase ty ret arms def _) =
    TypeCase ty ret arms def loc
  setLoc loc (CloE (Sub term subst)) =
    CloE $ Sub (setLoc loc term) subst
  setLoc loc (DCloE (Sub term subst)) =
    DCloE $ Sub (setLoc loc term) subst
  setLoc loc (QCloE (SubR term subst)) =
    QCloE $ SubR (setLoc loc term) subst

export
Relocatable (Term q d n) where
  setLoc loc (TYPE l _) = TYPE l loc
  setLoc loc (IOState _) = IOState loc
  setLoc loc (Pi qty arg res _) = Pi qty arg res loc
  setLoc loc (Lam body _) = Lam body loc
  setLoc loc (Sig fst snd _) = Sig fst snd loc
  setLoc loc (Pair fst snd _) = Pair fst snd loc
  setLoc loc (Enum cases _) = Enum cases loc
  setLoc loc (Tag tag _) = Tag tag loc
  setLoc loc (Eq ty l r _) = Eq ty l r loc
  setLoc loc (DLam body _) = DLam body loc
  setLoc loc (NAT _) = NAT loc
  setLoc loc (Nat n _) = Nat n loc
  setLoc loc (Succ p _) = Succ p loc
  setLoc loc (STRING _) = STRING loc
  setLoc loc (Str s _) = Str s loc
  setLoc loc (BOX qty ty _) = BOX qty ty loc
  setLoc loc (Box val _) = Box val loc
  setLoc loc (Let qty rhs body _) = Let qty rhs body loc
  setLoc loc (E e) = E $ setLoc loc e
  setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst
  setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst
  setLoc loc (QCloT (SubR term subst)) = QCloT $ SubR (setLoc loc term) subst

export
Relocatable1 f => Relocatable (ScopedBody s f n) where
  setLoc loc (Y body) = Y $ setLoc loc body
  setLoc loc (N body) = N $ setLoc loc body

export
Relocatable1 f => Relocatable (Scoped s f n) where
  setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body)


||| more convenient Pi
public export %inline
PiY : (qty : Qty q) -> (x : BindName) ->
      (arg : Term q d n) -> (res : Term q d (S n)) -> (loc : Loc) -> Term q d n
PiY {qty, x, arg, res, loc} = Pi {qty, arg, res = SY [< x] res, loc}

||| more convenient Lam
public export %inline
LamY : (x : BindName) -> (body : Term q d (S n)) -> (loc : Loc) -> Term q d n
LamY {x, body, loc} = Lam {body = SY [< x] body, loc}

public export %inline
LamN : (body : Term q d n) -> (loc : Loc) -> Term q d n
LamN {body, loc} = Lam {body = SN body, loc}

||| non dependent function type
public export %inline
Arr : (qty : Qty q) -> (arg, res : Term q d n) -> (loc : Loc) -> Term q d n
Arr {qty, arg, res, loc} = Pi {qty, arg, res = SN res, loc}

||| more convenient Sig
public export %inline
SigY : (x : BindName) -> (fst : Term q d n) ->
       (snd : Term q d (S n)) -> (loc : Loc) -> Term q d n
SigY {x, fst, snd, loc} = Sig {fst, snd = SY [< x] snd, loc}

||| non dependent pair type
public export %inline
And : (fst, snd : Term q d n) -> (loc : Loc) -> Term q d n
And {fst, snd, loc} = Sig {fst, snd = SN snd, loc}

||| more convenient Eq
public export %inline
EqY : (i : BindName) -> (ty : Term q (S d) n) ->
      (l, r : Term q d n) -> (loc : Loc) -> Term q d n
EqY {i, ty, l, r, loc} = Eq {ty = SY [< i] ty, l, r, loc}

||| more convenient DLam
public export %inline
DLamY : (i : BindName) -> (body : Term q (S d) n) -> (loc : Loc) -> Term q d n
DLamY {i, body, loc} = DLam {body = SY [< i] body, loc}

public export %inline
DLamN : (body : Term q d n) -> (loc : Loc) -> Term q d n
DLamN {body, loc} = DLam {body = SN body, loc}

||| non dependent equality type
public export %inline
Eq0 : (ty, l, r : Term q d n) -> (loc : Loc) -> Term q d n
Eq0 {ty, l, r, loc} = Eq {ty = SN ty, l, r, loc}

||| same as `F` but as a term
public export %inline
FT : Name -> Universe -> Loc -> Term q d n
FT x u loc = E $ F x u loc

||| same as `B` but as a term
public export %inline
BT : Var n -> (loc : Loc) -> Term q d n
BT i loc = E $ B i loc

||| abbreviation for a bound variable like `BV 4` instead of
||| `B (VS (VS (VS (VS VZ))))`
public export %inline
BV : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Elim q d n
BV i loc = B (V i) loc

||| same as `BV` but as a term
public export %inline
BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term q d n
BVT i loc = E $ BV i loc

public export %inline
Zero : Loc -> Term q d n
Zero = Nat 0

public export %inline
enum : List TagVal -> Loc -> Term q d n
enum ts loc = Enum (SortedSet.fromList ts) loc

public export %inline
typeCase : Elim q d n -> Term q d n ->
           List (TypeCaseArm q d n) -> Term q d n -> Loc -> Elim q d n
typeCase ty ret arms def loc = TypeCase ty ret (fromList arms) def loc

public export %inline
typeCase1Y : Elim q d n -> Term q d n ->
             (k : TyConKind) -> BContext (arity k) -> Term q d (arity k + n) ->
             (loc : Loc) ->
             {default (NAT loc) def : Term q d n} ->
             Elim q d n
typeCase1Y ty ret k ns body loc = typeCase ty ret [(k ** SY ns body)] def loc