quox/lib/Quox/Parser/Syntax.idr

153 lines
3.8 KiB
Idris
Raw Normal View History

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 [<] [<]