1 (* Copyright (C) 2017 Matthew Fluet.
2 * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor AstAtoms (S: AST_ATOMS_STRUCTS): AST_ATOMS =
15 structure Wrap = Region.Wrap
16 structure Field = Record.Field
18 structure Const = AstConst ()
22 structure Id = AstId (structure Symbol = Symbol)
28 String.length s > 1 andalso String.sub (s, 1) = #"'"
34 structure Id = AstId (structure Symbol = Symbol)
38 PrimTycons (structure AdmitsEquality = AdmitsEquality
39 structure CharSize = CharSize
40 structure IntSize = IntSize
41 structure Kind = TyconKind
42 structure RealSize = RealSize
43 structure WordSize = WordSize
46 Id.fromSymbol (Symbol.fromString s, Region.bogus))
50 structure Var = AstId (structure Symbol = Symbol)
54 structure Id = AstId (structure Symbol = Symbol)
59 fun fromString s = fromSymbol (Symbol.fromString s,
65 [cons, falsee, nill, reff, truee]
68 structure Basid = AstId (structure Symbol = Symbol)
69 structure Sigid = AstId (structure Symbol = Symbol)
70 structure Strid = AstId (structure Symbol = Symbol)
75 fun make s = fromSymbol (Symbol.fromString s, Region.bogus)
77 val uArg = fn s => make ("_arg_" ^ s)
78 val uRes = fn s => make ("_res_" ^ s)
79 val uStr = make "_str"
80 val uSig = make "_sig"
83 structure Fctid = AstId (structure Symbol = Symbol)
87 structure I = AstId (structure Symbol = Symbol)
90 fun fromCon c = fromSymbol (Con.toSymbol c, Con.region c)
91 fun fromVar x = fromSymbol (Var.toSymbol x, Var.region x)
93 fun make f v = f (toSymbol v, region v)
95 val toCon = make Con.fromSymbol
96 val toVar = make Var.fromSymbol
99 val it = fromSymbol (Symbol.itt, Region.bogus)
100 val equal = fromSymbol (Symbol.equal, Region.bogus)
101 val specialCons = List.map (Con.special, fromCon)
103 fun checkSpecial (oper, ctrl) (vid, {allowIt, ctxt, keyword}) =
104 if not (Control.Elaborate.current ctrl)
106 ((not allowIt andalso equals (vid, it))
110 List.exists (specialCons, fn vid' => equals (vid, vid')))
115 Control.error (region vid,
116 seq [str "special identifier cannot be ",
126 val checkRedefineSpecial =
127 checkSpecial ("redefined", Control.Elaborate.allowRedefineSpecialIds)
129 val checkSpecifySpecial =
130 checkSpecial ("specified", Control.Elaborate.allowSpecifySpecialIds)
133 structure Longtycon =
135 structure T = Longid (structure Id = Tycon
136 structure Strid = Strid
137 structure Symbol = Symbol)
141 val arrow = short Tycon.arrow
144 structure Longvar = Longid (structure Id = Var
145 structure Strid = Strid
146 structure Symbol = Symbol)
150 structure L = Longid (structure Id = Con
151 structure Strid = Strid
152 structure Symbol = Symbol)
157 structure Longstrid = Longid (structure Id = Strid
158 structure Strid = Strid
159 structure Symbol = Symbol)
164 structure L = Longid (structure Id = Vid
165 structure Strid = Strid
166 structure Symbol = Symbol)
170 fun to (make,node, conv) x =
171 let val (T {strids, id}, region) = dest x
172 in make (node {strids = strids, id = conv id}, region)
175 val toLongcon = to (Longcon.makeRegion, Longcon.T, Vid.toCon)
181 fun mkCtxt (x, lay) () =
182 seq [str "in: ", lay x]
184 fun reportDuplicates (v: 'a vector,
185 {ctxt: unit -> Layout.t,
186 equals: 'a * 'a -> bool,
187 layout: 'a -> Layout.t,
189 region: 'a -> Region.t}) =
197 if not (equals (a, Vector.sub (v, i')))
205 seq [str (concat ["duplicate ", name, ": "]), layout a],
212 fun reportDuplicateFields (v: (Field.t * (Region.t * 'a)) vector,
213 {ctxt: unit -> Layout.t}): unit =
216 equals = fn ((f, _), (f', _)) => Field.equals (f, f'),
217 layout = Field.layout o #1,
221 fun reportDuplicateTyvars (v: Tyvar.t vector,
222 {ctxt: unit -> Layout.t}): unit =
225 equals = Tyvar.equals,
226 layout = Tyvar.layout,
227 name = "type variable",
228 region = Tyvar.region})
234 Con of Longtycon.t * t vector
236 | Record of (Region.t * t) Record.t
238 withtype t = node Wrap.t
242 fun make n = makeRegion (n, Region.bogus)
244 val record = make o Record
245 val tuple = record o Record.tuple o (fn tys => Vector.map (tys, fn ty => (Region.bogus, ty)))
246 val unit = tuple (Vector.new0 ())
248 fun con (c: Tycon.t, ts: t vector): t =
249 if Tycon.equals (c, Tycon.tuple)
251 else make (Con (Longtycon.short c, ts))
253 fun arrow (t1, t2) = con (Tycon.arrow, Vector.new2 (t1, t2))
255 fun layoutApp (tycon, args: 'a vector, layoutArg) =
256 case Vector.length args of
258 | 1 => seq [layoutArg (Vector.first args), str " ", tycon]
259 | _ => seq [Vector.layout layoutArg args, str " ", tycon]
263 Var v => Tyvar.layout v
265 if Longtycon.equals (c, Longtycon.arrow)
266 then if 2 = Vector.length tys
269 [layout (Vector.first tys),
271 layout (Vector.sub (tys, 1))]])
272 else Error.bug "AstAtoms.Type.layout: non-binary -> tyc"
273 else layoutApp (Longtycon.layout c, tys, layout)
274 | Paren t => layout t
275 | Record r => Record.layout {record = r,
276 separator = ": ", extra = "",
277 layoutElt = layout o #2,
278 layoutTuple = fn rtys => layoutTupleTy (Vector.map (rtys, #2))}
279 and layoutTupleTy tys =
280 case Vector.length tys of
282 | 1 => layout (Vector.first tys)
283 | _ => paren (mayAlign (separateLeft (Vector.toListMap (tys, layout),
286 fun layoutOption ty =
289 | SOME ty => seq [str " of ", layout ty]
291 fun checkSyntax (t: t): unit =
293 Con (_, ts) => Vector.foreach (ts, checkSyntax)
294 | Paren t => checkSyntax t
296 (reportDuplicateFields (Record.toVector r,
297 {ctxt = mkCtxt (t, layout)})
298 ; Record.foreach (r, checkSyntax o #2))
302 fun bind (x, y) = mayAlign [seq [x, str " ="], y]
304 fun 'a layoutAndsSusp (prefix: string,
306 layoutX: bool * Layout.t * 'a -> Layout.t): (unit -> Layout.t) vector =
308 (xs, fn (i, x) => fn () =>
309 layoutX (i = 0, if i = 0 then str (concat [prefix, " "]) else str "and ", x))
311 fun 'a layoutAnds (prefix: string,
313 layoutX: Layout.t * 'a -> Layout.t): Layout.t =
314 align (Vector.toListMap (layoutAndsSusp (prefix, xs, fn (_, prefix, x) => layoutX (prefix, x)), fn th => th ()))
316 datatype bindStyle = OneLine | Split of int
318 fun 'a layoutBind (bind: string,
319 layout: 'a -> bindStyle * Layout.t * Layout.t)
320 (prefix: Layout.t, x: 'a): Layout.t =
322 val (style, lhs, rhs) = layout x
323 val lhs = seq [prefix, lhs, str " " , str bind]
326 OneLine => seq [lhs, str " ", rhs]
327 | Split indentation => align [lhs, indent (rhs, indentation)]
330 fun layoutAndsBind (prefix, bind, xs, layout) =
331 layoutAnds (prefix, xs, layoutBind (bind, layout))
333 (*---------------------------------------------------*)
335 (*---------------------------------------------------*)
340 T of {tycon: Tycon.t,
342 tyvars: Tyvar.t vector} vector
353 ("type", "=", ds, fn {tycon, def, tyvars} =>
355 Type.layoutApp (Tycon.layout tycon,
361 val empty = makeRegion (T (Vector.new0 ()), Region.bogus)
370 fun checkSyntax (b: t, kind: string): unit =
375 (v, fn {tyvars, tycon, def} =>
376 (reportDuplicateTyvars
377 (tyvars, {ctxt = fn () =>
381 tyvars, Tyvar.layout)]})
382 ; Type.checkSyntax def))
385 (v, {ctxt = mkCtxt (b, layout),
386 equals = (fn ({tycon = t, ...}, {tycon = t', ...}) =>
387 Tycon.equals (t, t')),
388 layout = Tycon.layout o #tycon,
389 name = "type " ^ kind,
390 region = Tycon.region o #tycon})
392 fun checkSyntaxDef b = checkSyntax (b, "definition")
393 fun checkSyntaxSpec b = checkSyntax (b, "specification")
396 (*---------------------------------------------------*)
398 (*---------------------------------------------------*)
403 T of {datatypes: {cons: (Con.t * Type.t option) vector,
405 tyvars: Tyvar.t vector} vector,
406 withtypes: TypBind.t}
413 fun layout (prefix, d) =
415 val T {datatypes, withtypes} = node d
419 (prefix, "=", datatypes, fn {tyvars, tycon, cons} =>
421 Type.layoutApp (Tycon.layout tycon, tyvars, Tyvar.layout),
422 alignPrefix (Vector.toListMap (cons, fn (c, to) =>
424 Type.layoutOption to]),
426 case TypBind.node withtypes of
430 else seq [str "with", TypBind.layout withtypes]]
433 fun checkSyntax (b: t, kind: string,
434 vidCheckSpecial: Vid.t * {allowIt: bool,
435 ctxt: unit -> Layout.t,
436 keyword: string} -> unit): unit =
438 val T {datatypes, withtypes} = node b
439 val TypBind.T withtypes = TypBind.node withtypes
440 val ctxt = mkCtxt ((), fn () => layout ("datatype", b))
443 (datatypes, fn {tyvars, tycon, cons} =>
444 (reportDuplicateTyvars
445 (tyvars, {ctxt = fn () =>
449 tyvars, Tyvar.layout)]})
456 keyword = "datatype"})
457 ; Option.app (to, Type.checkSyntax)))))
460 (Vector.concatV (Vector.map (datatypes, #cons)),
462 equals = fn ((c, _), (c', _)) => Con.equals (c, c'),
463 layout = Con.layout o #1,
464 name = "constructor " ^ kind,
465 region = Con.region o #1})
468 (withtypes, fn {tyvars, tycon, def} =>
469 (reportDuplicateTyvars
470 (tyvars, {ctxt = fn () =>
474 tyvars, Tyvar.layout)]})
475 ; Type.checkSyntax def))
478 (Vector.concat [Vector.map (datatypes, #tycon),
479 Vector.map (withtypes, #tycon)],
481 equals = Tycon.equals,
482 layout = Tycon.layout,
483 name = "type " ^ kind,
484 region = Tycon.region})
488 fun checkSyntaxDef b =
489 checkSyntax (b, "definition", Vid.checkRedefineSpecial)
490 fun checkSyntaxSpec b =
491 checkSyntax (b, "specification", Vid.checkSpecifySpecial)
494 structure DatatypeRhs =
498 | Repl of {lhs: Tycon.t, rhs: Longtycon.t}
507 DatBind d => DatBind.layout ("datatype", d)
509 seq [str "datatype ", Tycon.layout lhs,
510 str " = datatype ", Longtycon.layout rhs]
512 fun checkSyntax (rhs: t, datBindCheckSyntax) =
514 DatBind b => datBindCheckSyntax b
516 fun checkSyntaxDef rhs = checkSyntax (rhs, DatBind.checkSyntaxDef)
517 fun checkSyntaxSpec rhs = checkSyntax (rhs, DatBind.checkSyntaxSpec)
520 (*---------------------------------------------------*)
522 (*---------------------------------------------------*)
524 structure ModIdBind =
527 Fct of {lhs: Fctid.t, rhs: Fctid.t} vector
528 | Sig of {lhs: Sigid.t, rhs: Sigid.t} vector
529 | Str of {lhs: Strid.t, rhs: Strid.t} vector
538 fun doit (prefix, l, bds) =
540 (prefix, "=", bds, fn {lhs, rhs} => (OneLine, l lhs, l rhs))
543 Fct bds => doit ("functor", Fctid.layout, bds)
544 | Sig bds => doit ("signature", Sigid.layout, bds)
545 | Str bds => doit ("structure", Strid.layout, bds)
550 fun doit (bds : {lhs: 'a, rhs: 'a} Vector.t,
551 {equalsId, layoutId, regionId, name}) =
553 (bds, {ctxt = mkCtxt (d, layout),
554 equals = (fn ({lhs = id, ...}, {lhs = id', ...}) =>
556 layout = layoutId o #lhs,
557 name = concat [name, " definition"],
558 region = regionId o #lhs})
561 Fct bds => doit (bds, {equalsId = Fctid.equals,
562 layoutId = Fctid.layout,
563 regionId = Fctid.region,
565 | Sig bds => doit (bds, {equalsId = Sigid.equals,
566 layoutId = Sigid.layout,
567 regionId = Sigid.region,
569 | Str bds => doit (bds, {equalsId = Strid.equals,
570 layoutId = Strid.layout,
571 regionId = Strid.region,