quox/lib/Quox/Parser/Syntax.idr

214 lines
5.7 KiB
Idris

module Quox.Parser.Syntax
import public Quox.Syntax
import public Quox.Definition
import Derive.Prelude
%hide TT.Name
%default total
%language ElabReflection
public export
0 BName : Type
BName = Maybe String
public export
0 PUniverse : Type
PUniverse = Nat
namespace PDim
public export
data PDim = K DimConst | V PBaseName
%name PDim p, q
%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 Qty BName PTerm PTerm
| Lam BName PTerm
| (:@) PTerm PTerm
| Sig BName PTerm PTerm
| Pair PTerm PTerm
| Case Qty PTerm (BName, PTerm) (PCaseBody)
| Enum (List TagVal)
| Tag TagVal
| Eq (BName, PTerm) PTerm PTerm
| DLam BName PTerm
| (:%) PTerm PDim
| Nat
| Zero | Succ PTerm
| BOX Qty PTerm
| Box PTerm
| V PName
| (:#) PTerm PTerm
%name PTerm s, t
public export
data PCaseBody =
CasePair (BName, BName) PTerm
| CaseEnum (List (TagVal, PTerm))
| CaseNat PTerm (BName, Qty, BName, PTerm)
| CaseBox BName PTerm
%name PCaseBody body
%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show]
public export
record PDefinition where
constructor MkPDef
qty : Qty
name : PName
type : Maybe PTerm
term : PTerm
%name PDefinition def
%runElab derive "PDefinition" [Eq, Ord, Show]
mutual
public export
record PNamespace where
constructor MkPNamespace
name : Mods
decls : List PDecl
%name PNamespace ns
public export
data PDecl =
PDef PDefinition
| PNs PNamespace
%name PDecl decl
%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show]
public export
data PTopLevel = PD PDecl | PLoad String
%name PTopLevel t
%runElab derive "PTopLevel" [Eq, Ord, Show]
export
toPDimWith : Context' PBaseName 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' PBaseName d -> Context' PBaseName n ->
Term d n -> PTerm
toPTermWith ds ns t =
let Element t _ = pushSubsts t in
toPTermWith' ds ns t
private
toPTermWith' : Context' PBaseName d -> Context' PBaseName n ->
(t : Term d n) -> (0 _ : NotClo t) =>
PTerm
toPTermWith' ds ns s = case s of
TYPE l =>
TYPE l
Pi qty arg (S [< x] res) =>
Pi qty (Just $ show x)
(toPTermWith ds ns arg)
(toPTermWith ds (ns :< baseStr x) res.term)
Lam (S [< x] body) =>
Lam (Just $ show x) $
toPTermWith ds (ns :< baseStr x) body.term
Sig fst (S [< x] snd) =>
Sig (Just $ show x)
(toPTermWith ds ns fst)
(toPTermWith ds (ns :< baseStr 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 $ show i, toPTermWith (ds :< baseStr i) ns ty.term)
(toPTermWith ds ns l) (toPTermWith ds ns r)
DLam (S [< i] body) =>
DLam (Just $ show i) $ toPTermWith (ds :< baseStr i) ns body.term
Nat => Nat
Zero => Zero
Succ n => Succ $ toPTermWith ds ns n
BOX q ty => BOX q $ toPTermWith ds ns ty
Box val => Box $ toPTermWith ds ns val
E e =>
toPTermWith ds ns e
namespace Elim
export
toPTermWith : Context' PBaseName d -> Context' PBaseName n ->
Elim d n -> PTerm
toPTermWith ds ns e =
let Element e _ = pushSubsts e in
toPTermWith' ds ns e
private
toPTermWith' : Context' PBaseName d -> Context' PBaseName n ->
(e : Elim d n) -> (0 _ : NotClo e) =>
PTerm
toPTermWith' ds ns e = case e of
F x =>
V $ toPName x
B i =>
V $ MakePName [<] $ 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 $ show r, toPTermWith ds (ns :< baseStr r) ret.term)
(CasePair (Just $ show x, Just $ show y) $
toPTermWith ds (ns :< baseStr x :< baseStr y) body.term)
CaseEnum qty tag (S [< r] ret) arms =>
Case qty (toPTermWith ds ns tag)
(Just $ baseStr r, toPTermWith ds (ns :< baseStr r) ret.term)
(CaseEnum $ mapSnd (toPTermWith ds ns) <$> SortedMap.toList arms)
CaseNat qtyNat qtyIH nat (S [< r] ret) zer (S [< p, ih] suc) =>
Case qtyNat (toPTermWith ds ns nat)
(Just $ baseStr r, toPTermWith ds (ns :< baseStr r) ret.term)
(CaseNat (toPTermWith ds ns zer)
(Just $ baseStr p, qtyIH, Just $ baseStr ih,
toPTermWith ds (ns :< baseStr p :< baseStr ih) suc.term))
CaseBox qty box (S [< r] ret) (S [< b] body) =>
Case qty (toPTermWith ds ns box)
(Just $ baseStr r, toPTermWith ds (ns :< baseStr r) ret.term)
(CaseBox (Just $ baseStr b) $
toPTermWith ds (ns :< baseStr b) body.term)
fun :% arg =>
toPTermWith ds ns fun :% toPDimWith ds arg
tm :# ty =>
toPTermWith ds ns tm :# toPTermWith ds ns ty
namespace Term
export
toPTerm : Term 0 0 -> PTerm
toPTerm = toPTermWith [<] [<]
namespace Elim
export
toPTerm : Elim 0 0 -> PTerm
toPTerm = toPTermWith [<] [<]
public export
fromNat : Nat -> PTerm
fromNat 0 = Zero
fromNat (S k) = Succ $ fromNat k