153 lines
3.8 KiB
Idris
153 lines
3.8 KiB
Idris
|
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 [<] [<]
|