expr: 96.32%

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
#lang typed/racket
(provide (all-defined-out))
(require data-type)

(define-type (GBranch T) (HashTable Symbol T))

#|
Surface AST
|#
(define-type Branch (GBranch Expr))

(data Pat #:prefix
      [Pair Pat Pat]
      [Unit]
      [Var Symbol])

(struct Decl
  ([pattern : Pat]
   [prefix-parameters : (Vectorof Typed)]
   [signature : Expr]
   [body : Expr]
   [recursive? : Boolean]) #:transparent)

(struct Typed
  ([pattern : Pat]
   [expression : Expr])
  #:transparent)

;;; expression
(data Expr #:prefix E
      [Unit]
      [One]
      [Type Level]
      [Void]
      [Var Symbol]
      [Sum Branch]
      [Split Branch]
      [Merge Expr Expr]
      [Pi Typed Expr]
      [Sigma Typed Expr]
      [Lambda Pat (Option Value) Expr]
      [First Expr]
      [Second Expr]
      [Application Expr Expr]
      [Pair Expr Expr]
      [Constructor Symbol Expr]
      [Constant Pat Expr Expr]
      [Declaration Decl Expr])

#|
Abstract AST
|#
(define-type Level Natural)

(data (GTelescope V) #:prefix Tele
      [Nil]
      [UpDec (GTelescope V) Decl]
      [UpVar (GTelescope V) Pat V])
(define-type Telescope (GTelescope Value))

;;; closure
(data Clos #:prefix Cl
      [Abstraction Pat (Option Value) Expr Telescope]
      [Value Value]
      [Choice Clos Symbol])

(struct (E V) GCase
  ([expr : E]
   [context : (GTelescope V)])
  #:transparent)
(define-type Case (GCase (U Value Expr) Value))
(define-type CaseTree (GBranch Case))

(data (GNeutral V) #:prefix GN
      [Generated Symbol]
      [App (GNeutral V) V]
      [First (GNeutral V)]
      [Second (GNeutral V)]
      [Split (GBranch (GCase (U V Expr) V))
             (GNeutral V)])
(define-type Neutral (GNeutral Value))

;;; value
(data Value #:prefix V
      [Lambda Clos]
      [Unit]
      [One]
      [Type Level]
      [Pi Value Clos]
      [Sigma Value Clos]
      [Pair Value Value]
      [Constructor Symbol Value]
      [Split CaseTree]
      [Sum CaseTree]
      [Neu Neutral])

#|
Normal form AST
|#
(define-type NormalCase (GCase (U NormalExpr Expr) NormalExpr))
(define-type NormalCaseTree (GBranch NormalCase))

(define-type NormalNeutral (GNeutral NormalExpr))

(define-type NormalTelescope (GTelescope NormalExpr))

; normal expression
(data NormalExpr #:prefix NE
      [Lambda NormalExpr]
      [Pair NormalExpr NormalExpr]
      [Unit]
      [One]
      [Type Level]
      [Pi NormalExpr NormalExpr]
      [Sigma NormalExpr NormalExpr]
      [Constructor Symbol NormalExpr]
      [Split NormalCaseTree]
      [Sum NormalCaseTree]
      [Neu NormalNeutral])