mk-ast.sml 8.31 KB
Newer Older
mb0's avatar
mb0 committed
1
2
3
4

signature AST_CORE = sig
   type ty_bind
   type ty_use
Axel Simon's avatar
Axel Simon committed
5
6
   type syn_bind
   type syn_use
mb0's avatar
mb0 committed
7
8
9
10
   type con_bind
   type con_use
   type var_bind
   type var_use
Axel Simon's avatar
Axel Simon committed
11
12
   type field_bind
   type field_use
mb0's avatar
mb0 committed
13
   type op_id
mb0's avatar
mb0 committed
14
15
16
17
18
19
20
21
22
23
24
   val var_bind: var_bind -> Layout.layout
   val var_use: var_use -> Layout.layout
   val ty_bind: ty_bind -> Layout.layout
   val ty_use: ty_use -> Layout.layout
   val syn_bind: syn_bind -> Layout.layout
   val syn_use: syn_use -> Layout.layout
   val con_bind: con_bind -> Layout.layout
   val con_use: con_use -> Layout.layout
   val field_bind: field_bind -> Layout.layout
   val field_use: field_use -> Layout.layout
   val op_id: op_id -> Layout.layout
mb0's avatar
mb0 committed
25
26
27
28
29
30
31
32
end

functor MkAst (Core: AST_CORE) = struct
   (* a term marked with a source-map span *)
   type 'a mark = 'a Error.mark

   type ty_bind = Core.ty_bind
   type ty_use = Core.ty_use
Axel Simon's avatar
Axel Simon committed
33
34
   type syn_bind = Core.syn_bind
   type syn_use = Core.syn_use
mb0's avatar
mb0 committed
35
36
37
38
   type con_bind = Core.con_bind
   type con_use = Core.con_use
   type var_bind = Core.var_bind
   type var_use = Core.var_use
Axel Simon's avatar
Axel Simon committed
39
40
   type field_bind = Core.field_bind
   type field_use = Core.field_use
mb0's avatar
mb0 committed
41
42
   type op_id = Core.op_id

Axel Simon's avatar
Axel Simon committed
43
44
   type bitpat_lit = string

mb0's avatar
mb0 committed
45
46
47
   datatype decl =
      MARKdecl of decl mark
    | GRANULARITYdecl of IntInf.int
Axel Simon's avatar
Axel Simon committed
48
    | TYPEdecl of syn_bind * ty
mb0's avatar
mb0 committed
49
    | DATATYPEdecl of con_bind * (con_bind * ty option) list
50
    | DECODEdecl of var_bind * decodepat list * (exp, (exp * exp) list) Sum.t
mb0's avatar
mb0 committed
51
52
    | LETRECdecl of var_bind * var_bind list * exp
    | EXPORTdecl of var_use list
mb0's avatar
mb0 committed
53
54
55
56

   and ty =
      MARKty of ty mark
    | BITty of IntInf.int
Axel Simon's avatar
Axel Simon committed
57
    | NAMEDty of syn_use
mb0's avatar
mb0 committed
58
    | RECORDty of (field_bind * ty) list
mb0's avatar
mb0 committed
59
60
61

   and exp =
      MARKexp of exp mark
mb0's avatar
mb0 committed
62
    | LETRECexp of (var_bind * var_bind list * exp) list * exp
mb0's avatar
mb0 committed
63
    | IFexp of exp * exp * exp
mb0's avatar
mb0 committed
64
    | CASEexp of exp * (pat * exp) list
65
    | BINARYexp of exp * infixop * exp 
mb0's avatar
mb0 committed
66
    | APPLYexp of exp * exp list
Axel Simon's avatar
Axel Simon committed
67
    | RECORDexp of (field_bind * exp) list
mb0's avatar
mb0 committed
68
    | SELECTexp of field_use 
Axel Simon's avatar
Axel Simon committed
69
    | UPDATEexp of (field_bind * exp option) list (* functional record update "@{a=a'} *)
mb0's avatar
mb0 committed
70
71
    | LITexp of lit
    | SEQexp of seqexp list (* monadic sequence *)
mb0's avatar
mb0 committed
72
    | IDexp of var_use 
mb0's avatar
mb0 committed
73
    | CONexp of con_use (* constructor *)
74
    | FNexp of var_bind list * exp 
mb0's avatar
mb0 committed
75

76
77
78
79
   and infixop =
      MARKinfixop of infixop mark
    | OPinfixop of op_id

mb0's avatar
mb0 committed
80
81
82
83
84
85
86
87
88
89
90
91
   and seqexp =
      MARKseqexp of seqexp mark
    | ACTIONseqexp of exp
    | BINDseqexp of var_bind * exp

   and decodepat =
      MARKdecodepat of decodepat mark
    | TOKENdecodepat of tokpat
    | BITdecodepat of bitpat list

   and bitpat =
      MARKbitpat of bitpat mark
Axel Simon's avatar
Axel Simon committed
92
    | BITSTRbitpat of bitpat_lit
Axel Simon's avatar
Axel Simon committed
93
    | NAMEDbitpat of var_use
94
    | BITVECbitpat of var_bind * bitpat_lit
mb0's avatar
mb0 committed
95
96
97
98

   and tokpat =
      MARKtokpat of tokpat mark
    | TOKtokpat of IntInf.int
99
    | NAMEDtokpat of var_use
mb0's avatar
mb0 committed
100
101
102
103

   and pat =
      MARKpat of pat mark
    | LITpat of lit
Axel Simon's avatar
Axel Simon committed
104
    | IDpat of var_bind
105
    | CONpat of con_use * pat option
mb0's avatar
mb0 committed
106
107
108
109
110
111
    | WILDpat

   and lit =
      INTlit of IntInf.int
    | FLTlit of FloatLit.float
    | STRlit of string
Axel Simon's avatar
Axel Simon committed
112
    | VEClit of bitpat_lit
mb0's avatar
mb0 committed
113

114
   type specification = decl list
mb0's avatar
mb0 committed
115

116
   structure PP = struct
mb0's avatar
mb0 committed
117
      open Layout Pretty Core
118

119
120
      val is = seq [space, str "="]

121
      fun spec (ss:specification) = align (map decl ss)
122
123
124

      and decl t =
         case t of
mb0's avatar
mb0 committed
125
            MARKdecl t' => decl (#tree t')
126
          | GRANULARITYdecl i => seq [str "granularity", is, space, int i]
mb0's avatar
mb0 committed
127
          | EXPORTdecl es =>
128
129
130
               seq
                  [str "export", is, space,
                   seq (separate (map var_use es, " "))]
mb0's avatar
mb0 committed
131
132
133
134
          | TYPEdecl (t, tyexp) =>
               seq [str "type", space, syn_bind t, space, ty tyexp]
          | DATATYPEdecl (t, decls) =>
               align
mb0's avatar
Up.    
mb0 committed
135
                  [seq [str "type", space, con_bind t],
mb0's avatar
mb0 committed
136
                   indent 3 (alignPrefix (map condecl decls, "| "))]
137
          | DECODEdecl (n, ps, Sum.INL e) =>
mb0's avatar
Up.    
mb0 committed
138
139
               align [seq [var_bind n, space, decodepats ps],
                           indent 1 (block e)]
140
          | DECODEdecl (n, ps, Sum.INR ges) =>
mb0's avatar
mb0 committed
141
142
               align
                  [seq
mb0's avatar
Up.    
mb0 committed
143
144
145
                     [var_bind n, space, decodepats ps],
                   indent 1
                     (align
mb0's avatar
mb0 committed
146
147
                        (map
                           (fn (e1, e2) =>
mb0's avatar
Up.    
mb0 committed
148
149
150
                              align [seq [exp e1, str ":"],
                                     indent 1 (block e2)])
                           ges))]
mb0's avatar
mb0 committed
151
          | LETRECdecl d => recdecl d
152

153
      and decodepats ps =
154
         seq
Axel Simon's avatar
Axel Simon committed
155
            [str "[",
156
             seq (separate (map decodepat ps, " ")),
Axel Simon's avatar
Axel Simon committed
157
             str "]"]
Axel Simon's avatar
Axel Simon committed
158

mb0's avatar
mb0 committed
159
160
161
      and decodepat t =
         case t of
            MARKdecodepat t' => decodepat (#tree t')
162
          | BITdecodepat bp => listex "'" "'" " " (map bitpat bp)
mb0's avatar
mb0 committed
163
          | TOKENdecodepat tp => tokpat tp
164

mb0's avatar
mb0 committed
165
166
167
168
169
      and bitpat t =
         case t of
            MARKbitpat t' => bitpat (#tree t')
          | BITSTRbitpat s => str s
          | NAMEDbitpat n => var_use n
170
          | BITVECbitpat (n, s) => seq [var_bind n, str ":", str s]
171

mb0's avatar
mb0 committed
172
173
174
175
      and tokpat t =
         case t of
            MARKtokpat t' => tokpat (#tree t')
          | TOKtokpat tok => str (IntInf.fmt StringCvt.HEX tok)
176
          | NAMEDtokpat n => var_use n
177

mb0's avatar
mb0 committed
178
      and guardedexp gexp = tuple2 (exp, exp) gexp
179

mb0's avatar
mb0 committed
180
181
182
183
      and condecl (n, tyOpt) =
         case tyOpt of
            NONE => con_bind n
          | SOME t => seq [con_bind n, space, ty t]
184

mb0's avatar
mb0 committed
185
186
187
188
189
      and ty t =
         case t of
            MARKty t' => ty (#tree t')
          | BITty i => int i
          | NAMEDty alias => Core.syn_use alias
mb0's avatar
mb0 committed
190
          | RECORDty fields => list (map (tuple2 (field_bind, ty)) fields)
191

mb0's avatar
mb0 committed
192
193
194
195
196
      and pat t =
         case t of
            MARKpat t' => pat (#tree t')
          | LITpat l => lit l
          | IDpat n => var_bind n
197
198
          | CONpat (n, SOME p) => seq [con_use n, space, pat p]
          | CONpat (n, _) => con_use n
mb0's avatar
mb0 committed
199
          | WILDpat => str "_"
200

mb0's avatar
mb0 committed
201
202
203
204
205
      and lit t =
         case t of
            INTlit i => int i
          | FLTlit f => str (FloatLit.toString f)
          | STRlit s => str s
mb0's avatar
Merge.    
mb0 committed
206
          | VEClit s => seq [str "'", str s, str "'"]
207

mb0's avatar
Up.    
mb0 committed
208
209
      and block t = align [seq [lb, exp t], rb]

mb0's avatar
mb0 committed
210
211
212
      and exp t =
         case t of
            MARKexp t' => exp (#tree t')
mb0's avatar
mb0 committed
213
          | LETRECexp (ds, e) =>
mb0's avatar
Up.    
mb0 committed
214
215
               align [align (map recdecl ds),
                      exp e]
mb0's avatar
mb0 committed
216
          | IFexp (iff, thenn, elsee) =>
mb0's avatar
Up.    
mb0 committed
217
218
219
220
               align [seq [str "if", space, lp, exp iff, rp],
                      indent 1 (block thenn),
                      str "else",
                      indent 1 (block elsee)]
mb0's avatar
mb0 committed
221
222
          | CASEexp (e, cs) =>
               align
mb0's avatar
Up.    
mb0 committed
223
224
225
                  [seq [str "case", space, lp, exp e, rp],
                   (indent 1 (align [seq [lb, align (map casee cs)],
                                     rb]))]
mb0's avatar
mb0 committed
226
          | BINARYexp (e1, opid, e2) =>
mb0's avatar
Up.    
mb0 committed
227
228
               seq [exp e1, space, infixop opid, space, exp e2]
          | APPLYexp (e1, es) => seq [exp e1, args (map exp es)]
mb0's avatar
mb0 committed
229
230
          | RECORDexp fs => listex "{" "}" "," (map field fs)
          | SELECTexp f => seq [str "$", field_use f]
Axel Simon's avatar
Axel Simon committed
231
          | UPDATEexp fs => seq [str "@", listex "{" "}" "," (map fieldOpt fs)]
mb0's avatar
mb0 committed
232
          | LITexp l => lit l
mb0's avatar
Up.    
mb0 committed
233
          | SEQexp ss => align (separateRight (map seqexp ss, ";"))
mb0's avatar
mb0 committed
234
          | IDexp id => var_use id
mb0's avatar
Up.    
mb0 committed
235
236
237
238
          | CONexp con => con_use con
          | FNexp (xs, e) => seq [args (map var_bind xs), indent 1 (block e)]

      and args x = listex "(" ")" "," x
mb0's avatar
mb0 committed
239

240
241
242
243
244
      and infixop t =
         case t of
            MARKinfixop t' => infixop (#tree t')
          | OPinfixop opid => op_id opid
          
mb0's avatar
mb0 committed
245
246
247
      and recdecl (n, args, e) =
         align
            [seq
mb0's avatar
Up.    
mb0 committed
248
249
250
               [var_bind n, space, lp,
                seq (separate (map var_bind args, " ")), rp],
             indent 1 (block e)]  
mb0's avatar
mb0 committed
251
252
253
254
255
256
257
258
259
260

      and seqexp t =
         case t of
            MARKseqexp t' => seqexp (#tree t')
          | ACTIONseqexp act => exp act
          | BINDseqexp (n, e) =>
               seq [var_bind n, space, str "<-", space, exp e]

      and field (n, e) = seq [field_bind n, str "=", exp e]

Axel Simon's avatar
Axel Simon committed
261
262
263
      and fieldOpt (n, SOME e) = seq [field_bind n, str "=", exp e]
        | fieldOpt (n, NONE) = seq [str "~", field_bind n]

mb0's avatar
mb0 committed
264
265
      and casee (p, e) =
         align
mb0's avatar
Up.    
mb0 committed
266
267
            [seq [pat p, str ":"],
             indent 1 (block e)]
268

mb0's avatar
mb0 committed
269
270
      and def (nameAndArgs, body) = align [nameAndArgs, indent 2 body]

271
      val pretty = Pretty.pretty o spec
mb0's avatar
mb0 committed
272
      fun prettyTo (os, t) = Pretty.prettyTo (os, spec t)
273
   end
274
end