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 AstModules (S: AST_MODULES_STRUCTS): AST_MODULES =
15 structure AstCore = AstCore (AstAtoms (S))
19 fun mkCtxt (x, lay) () =
20 seq [str "in: ", lay x]
22 val layouts = List.map
23 structure Wrap = Region.Wrap
26 structure WhereEquation =
30 Type of {tyvars: Tyvar.t vector,
31 longtycon: Longtycon.t,
39 Type {tyvars, longtycon, ty} =>
40 seq [str "where type ",
41 Type.layoutApp (Longtycon.layout longtycon, tyvars, Tyvar.layout),
47 Type {tyvars, longtycon, ty} =>
48 (reportDuplicateTyvars
49 (tyvars, {ctxt = fn () =>
52 (Longtycon.layout longtycon,
53 tyvars, Tyvar.layout)]})
54 ; Type.checkSyntax ty)
58 structure SharingEquation =
62 Type of Longtycon.t list
63 | Structure of Longstrid.t list
71 seq (str "sharing type "
72 :: separate (List.map (longtycons, Longtycon.layout), " = "))
73 | Structure longstrids =>
75 :: separate (List.map (longstrids, Longstrid.layout), " = "))
78 type typedescs = {tyvars: Tyvar.t vector,
79 tycon: Tycon.t} vector
83 | Where of {equations: WhereEquation.t vector,
88 | Transparent of sigexp
91 Datatype of DatatypeRhs.t
94 | Exception of (Con.t * Type.t option) vector
95 | IncludeSigexp of sigexp
96 | IncludeSigids of Sigid.t vector
98 | Sharing of {equation: SharingEquation.t,
100 | Structure of (Strid.t * sigexp) vector
102 | TypeDefs of TypBind.t
103 | Val of (Var.t * Type.t) vector
104 withtype spec = specNode Wrap.t
105 and sigexp = sigexpNode Wrap.t
107 fun layoutTypedescs (prefix, typedescs) =
108 layoutAnds (prefix, typedescs, fn (prefix, {tyvars, tycon}) =>
110 Type.layoutApp (Tycon.layout tycon, tyvars, Tyvar.layout)])
112 fun layoutTypedefs (prefix, typBind) =
114 val TypBind.T ds = TypBind.node typBind
116 layoutAnds (prefix, ds, fn (prefix, {def, tycon, tyvars}) =>
118 Type.layoutApp (Tycon.layout tycon, tyvars, Tyvar.layout),
119 str " = ", Type.layout def])
122 fun layoutSigexp (e: sigexp): Layout.t =
124 Var s => Sigid.layout s
125 | Where {sigexp, equations} =>
127 val sigexp = layoutSigexp sigexp
129 if Vector.isEmpty equations
133 align (Vector.toListMap (equations, WhereEquation.layout))]
135 | Spec s => align [str "sig",
136 indent (layoutSpec s, 3),
139 and layoutSigConst sigConst =
142 | Transparent s => seq [str ": ", layoutSigexp s]
143 | Opaque s => seq [str " :> ", layoutSigexp s]
145 and layoutSpec (s: spec): t =
147 Datatype rhs => DatatypeRhs.layout rhs
149 | Eqtype typedescs => layoutTypedescs ("eqtype", typedescs)
152 ("exception", sts, fn (prefix, (c, to)) => seq [prefix,
154 Type.layoutOption to])
155 | IncludeSigexp s => seq [str "include ", layoutSigexp s]
156 | IncludeSigids sigids =>
158 :: separate (Vector.toListMap (sigids, Sigid.layout), " "))
159 | Seq (s, s') => align [layoutSpec s, layoutSpec s']
160 | Sharing {spec, equation} =>
161 align [layoutSpec spec,
162 SharingEquation.layout equation]
164 layoutAndsBind ("structure", ":", l, fn (strid, sigexp) =>
169 layoutSigexp sigexp))
170 | Type typedescs => layoutTypedescs ("type", typedescs)
171 | TypeDefs typedefs => layoutTypedefs ("type", typedefs)
174 ("val", ":", sts, fn (x, t) => (OneLine, Var.layout x, Type.layout t))
176 fun checkSyntaxSigexp (e: sigexp): unit =
178 Spec s => checkSyntaxSpec s
180 | Where {sigexp, equations} =>
181 (checkSyntaxSigexp sigexp
183 (equations, WhereEquation.checkSyntax))
185 and checkSyntaxSigConst (s: sigConst): unit =
188 | Opaque e => checkSyntaxSigexp e
189 | Transparent e => checkSyntaxSigexp e
191 and checkSyntaxTypedescs (typedescs, {ctxt}) =
193 (typedescs, fn {tyvars, tycon, ...} =>
194 reportDuplicateTyvars
195 (tyvars, {ctxt = fn () =>
199 tyvars, Tyvar.layout)]}))
201 (typedescs, {ctxt = ctxt,
202 equals = (fn ({tycon = c, ...}, {tycon = c', ...}) =>
203 Tycon.equals (c, c')),
204 layout = Tycon.layout o #tycon,
205 name = "type specification",
206 region = Tycon.region o #tycon}))
208 and checkSyntaxSpec (s: spec): unit =
210 val ctxt = mkCtxt (s, layoutSpec)
213 Datatype d => DatatypeRhs.checkSyntaxSpec d
214 | Eqtype typedescs => checkSyntaxTypedescs (typedescs, {ctxt = ctxt})
219 (Vid.checkSpecifySpecial
223 keyword = "exception"})
224 ; Option.app (to, Type.checkSyntax)))
227 equals = fn ((c, _), (c', _)) => Con.equals (c, c'),
228 layout = Con.layout o #1,
229 name = "exception specification",
230 region = Con.region o #1})))
231 | IncludeSigexp e => checkSyntaxSigexp e
232 | IncludeSigids _ => ()
233 | Seq (s, s') => (checkSyntaxSpec s; checkSyntaxSpec s')
234 | Sharing {spec, ...} => checkSyntaxSpec spec
236 (Vector.foreach (v, checkSyntaxSigexp o #2)
239 equals = fn ((s, _), (s', _)) => Strid.equals (s, s'),
240 layout = Strid.layout o #1,
241 name = "structure specification",
242 region = Strid.region o #1})))
243 | Type typedescs => checkSyntaxTypedescs (typedescs, {ctxt = ctxt})
244 | TypeDefs b => TypBind.checkSyntaxSpec b
248 (Vid.checkSpecifySpecial
253 ; Type.checkSyntax t))
256 equals = fn ((x, _), (x', _)) => Var.equals (x, x'),
257 layout = Var.layout o #1,
258 name = "value specification",
259 region = Var.region o #1})))
267 datatype node = datatype sigexpNode
271 val checkSyntax = checkSyntaxSigexp
273 fun wheree (sigexp: t, equations): t =
274 if Vector.isEmpty equations
276 else makeRegion (Where {sigexp = sigexp,
277 equations = equations},
281 (Vector.last equations)))
283 fun make n = makeRegion (n, Region.bogus)
285 val spec = make o Spec
287 val layout = layoutSigexp
292 datatype t = datatype sigConst
294 val checkSyntax = checkSyntaxSigConst
295 val layout = layoutSigConst
301 datatype node = datatype specNode
306 val checkSyntax = checkSyntaxSpec
307 val layout = layoutSpec
310 (*---------------------------------------------------*)
311 (* Strdecs and Strexps *)
312 (*---------------------------------------------------*)
314 datatype strdecNode =
316 | Local of strdec * strdec
318 | ShowBasis of File.t
319 | Structure of {constraint: SigConst.t,
321 name: Strid.t} vector
324 App of Fctid.t * strexp
325 | Constrained of strexp * SigConst.t
326 | Let of strdec * strexp
329 withtype strexp = strexpNode Wrap.t
330 and strdec = strdecNode Wrap.t
334 Core d => Dec.layout d
335 | Local (d, d') => Pretty.locall (layoutStrdec d, layoutStrdec d')
336 | Seq ds => align (layoutStrdecs ds)
337 | ShowBasis file => seq [str "(*#showBasis \"",
341 layoutAndsBind ("structure", "=", strbs,
342 fn {name, def, constraint} =>
346 seq [Strid.layout name, SigConst.layout constraint],
349 and layoutStrdecs ds = layouts (ds, layoutStrdec)
351 and layoutStrexp exp =
353 App (f, e) => seq [Fctid.layout f, str " ", paren (layoutStrexp e)]
354 | Constrained (e, c) => mayAlign [layoutStrexp e, SigConst.layout c]
355 | Let (dec, strexp) => Pretty.lett (layoutStrdec dec, layoutStrexp strexp)
356 | Struct d => align [str "struct",
357 indent (layoutStrdec d, 3),
359 | Var s => Longstrid.layout s
361 fun checkSyntaxStrdec (d: strdec): unit =
363 Core d => Dec.checkSyntax d
364 | Local (d, d') => (checkSyntaxStrdec d; checkSyntaxStrdec d')
365 | Seq ds => List.foreach (ds, checkSyntaxStrdec)
368 (Vector.foreach (v, fn {constraint, def, ...} =>
369 (SigConst.checkSyntax constraint
370 ; checkSyntaxStrexp def))
372 (v, {ctxt = mkCtxt (d, layoutStrdec),
373 equals = (fn ({name = n, ...}, {name = n', ...}) =>
374 Strid.equals (n, n')),
375 layout = Strid.layout o #name,
376 name = "structure definition",
377 region = Strid.region o #name})))
378 and checkSyntaxStrexp (e: strexp): unit =
380 App (_, e) => checkSyntaxStrexp e
381 | Constrained (e, c) => (checkSyntaxStrexp e
382 ; SigConst.checkSyntax c)
383 | Let (d, e) => (checkSyntaxStrdec d
384 ; checkSyntaxStrexp e)
385 | Struct d => checkSyntaxStrdec d
393 datatype node = datatype strexpNode
397 val checkSyntax = checkSyntaxStrexp
398 fun make n = makeRegion (n, Region.bogus)
399 val constrained = make o Constrained
400 val lett = make o Let
402 val layout = layoutStrexp
409 datatype node = datatype strdecNode
413 val checkSyntax = checkSyntaxStrdec
414 fun make n = makeRegion (n, Region.bogus)
416 val core = make o Core
418 val openn = core o Dec.openn
420 val structuree = make o Structure o Vector.new1
422 val layout = layoutStrdec
424 val fromExp = core o Dec.fromExp
426 val trace = Trace.trace ("AstModules.Strdec.coalesce", layout, layout)
427 fun coalesce (d: t): t =
437 case (node d1, node d2) of
438 (Core d1', Core d2') =>
440 (Dec.Local (d1', d2'),
441 Region.append (region d1, region d2)))
442 | _ => Local (d1, d2)
444 makeRegion (node, region d)
448 fun finish (ds: Dec.t list, ac: t list): t list =
454 makeRegion (Core (Dec.makeRegion
455 (Dec.SeqDec (Vector.fromListRev ds),
461 fun loop (ds, cores, ac) =
463 [] => finish (cores, ac)
469 Core d => loop (ds, d :: cores, ac)
470 | Seq ds' => loop (ds' @ ds, cores, ac)
471 | _ => loop (ds, [], d :: finish (cores, ac))
475 case loop (ds, [], []) of
476 [] => makeRegion (Core (Dec.makeRegion
477 (Dec.SeqDec (Vector.new0 ()), r)),
480 | ds => makeRegion (Seq (rev ds), r)
483 | Structure _ => d) d
490 Structure of Strid.t * Sigexp.t
498 Structure (strid, sigexp) =>
499 seq [Strid.layout strid, str ": ", Sigexp.layout sigexp]
500 | Spec spec => Spec.layout spec
502 fun checkSyntax (fa: t): unit =
504 Structure (_, e) => Sigexp.checkSyntax e
505 | Spec s => Spec.checkSyntax s
512 Functor of {arg: FctArg.t,
515 result: SigConst.t} vector
516 | Signature of (Sigid.t * Sigexp.t) vector
525 layoutAndsBind ("functor", "=", fctbs,
526 fn {name, arg, result, body} =>
528 seq [Fctid.layout name, str " ",
529 paren (FctArg.layout arg),
530 layoutSigConst result],
533 layoutAndsBind ("signature", "=", sigbs,
535 (case Sigexp.node def of
536 Sigexp.Var _ => OneLine
540 | Strdec d => Strdec.layout d
543 fun make n = makeRegion (n, Region.bogus)
544 val fromExp = make o Strdec o Strdec.fromExp
546 fun checkSyntax (d: t): unit =
550 (v, fn {arg, body, result, ...} =>
551 (FctArg.checkSyntax arg
552 ; Strexp.checkSyntax body
553 ; SigConst.checkSyntax result))
555 (v, {ctxt = mkCtxt (d, layout),
556 equals = (fn ({name = n, ...}, {name = n', ...}) =>
557 Fctid.equals (n, n')),
558 layout = Fctid.layout o #name,
559 name = "functor definition",
560 region = Fctid.region o #name})))
562 (Vector.foreach (bs, Sigexp.checkSyntax o #2)
565 {ctxt = mkCtxt (d, layout),
566 equals = fn ((s, _), (s', _)) => Sigid.equals (s, s'),
567 layout = Sigid.layout o #1,
568 name = "signature definition",
569 region = Sigid.region o #1})))
570 | Strdec d => Strdec.checkSyntax d