module Quox.Parser.Syntax

import public Quox.Syntax
import public Quox.Syntax.Qty.Three

import Derive.Prelude
%hide TT.Name

%default total
%language ElabReflection


public export
0 BName : Type
BName = Maybe BaseName

public export
0 PUniverse : Type
PUniverse = Nat

public export
0 PQty : Type
PQty = Three

namespace PDim
  public export
  data PDim = K DimConst | V BaseName
  %runElab derive "PDim" [Eq, Ord, Show]

namespace PTerm
  mutual
    ||| terms out of the parser with BVs and bidirectionality still tangled up
    public export
    data PTerm =
        TYPE Nat

      | Pi PQty BName PTerm PTerm
      | Lam BName PTerm
      | (:@) PTerm PTerm

      | Sig BName PTerm PTerm
      | Pair PTerm PTerm
      | Case PQty PTerm (BName, PTerm) (PCaseBody)

      | Enum (List TagVal)
      | Tag TagVal

      | Eq (BName, PTerm) PTerm PTerm
      | DLam BName PTerm
      | (:%) PTerm PDim

      | V Name
      | (:#) PTerm PTerm

    public export
    data PCaseBody =
        CasePair (BName, BName) PTerm
      | CaseEnum (List (TagVal, PTerm))

%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show]


export
toPDimWith : Context' BaseName d -> Dim d -> PDim
toPDimWith ds (K e) = K e
toPDimWith ds (B i) = V $ ds !!! i

export
toPDim : Dim 0 -> PDim
toPDim = toPDimWith [<]


mutual
  namespace Term
    export
    toPTermWith : Context' BaseName d -> Context' BaseName n ->
                  Term Three d n -> PTerm
    toPTermWith ds ns t =
      let Element t _ = pushSubsts t in
      toPTermWith' ds ns t

    private
    toPTermWith' : Context' BaseName d -> Context' BaseName n ->
                   (t : Term Three d n) -> (0 _ : NotClo t) =>
                   PTerm
    toPTermWith' ds ns s = case s of
      TYPE (U l) =>
        TYPE l
      Pi qty arg (S [x] res) =>
        Pi qty (Just x) (toPTermWith ds ns arg)
                        (toPTermWith ds (ns :< x) res.term)
      Lam (S [x] body) =>
        Lam (Just x) $ toPTermWith ds (ns :< x) body.term
      Sig fst (S [x] snd) =>
        Sig (Just x) (toPTermWith ds ns fst)
                     (toPTermWith ds (ns :< x) snd.term)
      Pair fst snd =>
        Pair (toPTermWith ds ns fst) (toPTermWith ds ns snd)
      Enum cases =>
        Enum $ SortedSet.toList cases
      Tag tag =>
        Tag tag
      Eq (S [i] ty) l r =>
        Eq (Just i, toPTermWith (ds :< i) ns ty.term)
           (toPTermWith ds ns l) (toPTermWith ds ns r)
      DLam (S [i] body) =>
        DLam (Just i) $ toPTermWith (ds :< i) ns body.term
      E e =>
        toPTermWith ds ns e

  namespace Elim
    export
    toPTermWith : Context' BaseName d -> Context' BaseName n ->
                  Elim Three d n -> PTerm
    toPTermWith ds ns e =
      let Element e _ = pushSubsts e in
      toPTermWith' ds ns e

    private
    toPTermWith' : Context' BaseName d -> Context' BaseName n ->
                   (e : Elim Three d n) -> (0 _ : NotClo e) =>
                   PTerm
    toPTermWith' ds ns e = case e of
      F x =>
        V x
      B i =>
        V $ unq $ ns !!! i
      fun :@ arg =>
        toPTermWith ds ns fun :@ toPTermWith ds ns arg
      CasePair qty pair (S [r] ret) (S [x, y] body) =>
        Case qty (toPTermWith ds ns pair)
             (Just r, toPTermWith ds (ns :< r) ret.term)
             (CasePair (Just x, Just y) $
                toPTermWith ds (ns :< x :< y) body.term)
      CaseEnum qty tag (S [r] ret) arms =>
        Case qty (toPTermWith ds ns tag)
             (Just r, toPTermWith ds (ns :< r) ret.term)
             (CaseEnum $ mapSnd (toPTermWith ds ns) <$> SortedMap.toList arms)
      fun :% arg =>
        toPTermWith ds ns fun :% toPDimWith ds arg
      tm :# ty =>
        toPTermWith ds ns tm :# toPTermWith ds ns ty

namespace Term
  export
  toPTerm : Term Three 0 0 -> PTerm
  toPTerm = toPTermWith [<] [<]

namespace Elim
  export
  toPTerm : Elim Three 0 0 -> PTerm
  toPTerm = toPTermWith [<] [<]