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
|
use "Result.sml";
use "Map.sml";
use "Syntax.sml";
use "Parser.sml";
use "Opts.sml";
val header =
"fun intToStringI (_ : string) (i : int) : string = Int.toString i\n"
^ "\n"
^ "fun varToStringI (_ : string) (v : Syntax.var) : string = \"Var \" ^ Int.toString v\n"
^ "\n"
^ "fun stringToStringI (_ : string) (s : string) : string = \"\\\"\" ^ String.toString s ^ \"\\\"\"\n"
^ "\n"
^ "fun optionToString (_ : string -> 'a -> string) (_ : string) NONE : string = \"NONE\"\n"
^ " | optionToString show indent (SOME x) = \"SOME (\" ^ show indent x ^ \")\"\n"
^ "\n"
^ "fun listToString (_ : string -> 'a -> string) (_ : string) ([] : 'a list) : string = \"[]\"\n"
^ " | listToString show indent [x] = \"[\" ^ show indent x ^ \"]\"\n"
^ " | listToString show indent xs =\n"
^ " let val indent' = indent ^ \" \" in\n"
^ " \"[\\n\"\n"
^ " ^ indent' ^ String.concatWith (\",\\n\" ^ indent') (map (show indent') xs) ^ \"\\n\"\n"
^ " ^ indent ^ \"]\"\n"
^ " end\n"
fun showTy (Syntax.Tyvar var) : string = var ^ "ToStringI"
| showTy (Syntax.Tycon ([ty], con)) = con ^ "ToString (" ^ showTy ty ^ ")"
| showTy (Syntax.TyTuple tys) =
let val vars = List.tabulate (length tys, fn i => "x" ^ Int.toString i) in
"(fn indent => fn (" ^ String.concatWith ", " vars ^ ") => let val indent' = indent ^ \" \" in \"(\\n\" ^ indent' ^ " ^ String.concatWith " ^ \",\\n\" ^ indent' ^ " (map (fn (var, ty) => showTy ty ^ " indent' " ^ var) (ListPair.zip (vars, tys))) ^ " ^ \"\\n\" ^ indent ^ \")\" end)"
end
| showTy _ = "(fn _ => fn _ => \"UNHANDLED\")"
val opts = { o = ref "/dev/stdout" }
val flags =
[ ("o", Opts.StringOpt (fn arg => #o opts := arg)) ]
val filename =
case Opts.getOpt flags (CommandLine.arguments ()) of
[arg] => arg
| _ => raise Fail "usage: showsyntax <filename>"
val ast =
case Parser.parse filename of
Result.Left e => raise Fail e
| Result.Right x => x
val (structName, decls) =
case ast of
Syntax.ELet (Syntax.DStruct (structName, Syntax.SStruct decls) :: _, _) => (structName, decls)
| _ => raise Fail "ast has unexpected format (I can't print it sorry)"
val out = TextIO.openOut (!(#o opts))
val _ = TextIO.output (out, "(*\n This file was generated by generate-show-syntax.sml. Do not edit manually.\n To regenerate, use\n\n sml generate-show-syntax.sml -o " ^ !(#o opts) ^ " " ^ filename ^ "\n*)\n\n")
val _ = TextIO.output (out, "structure Show" ^ structName ^ " = struct\n")
val _ = TextIO.output (out, header)
val _ = map
(fn (i, Syntax.DDatatype (typeName, cases)) =>
(TextIO.output (out,
"\n" ^ (if i = 0 then "fun" else "and") ^ " "
^ String.concatWith "\n | " (map
(fn (caseName, NONE) => typeName ^ "ToStringI (indent : string) (" ^ structName ^ "." ^ caseName ^ " : " ^ structName ^ "." ^ typeName ^ ") : string =\n \"" ^ caseName ^ "\""
| (caseName, SOME ty) => typeName ^ "ToStringI (indent : string) (" ^ structName ^ "." ^ caseName ^ " x : " ^ structName ^ "." ^ typeName ^ ") : string =\n \"" ^ caseName ^ " \" ^ " ^ showTy ty ^ " indent x")
cases)
^ "\n") ;
TextIO.output (out, "and " ^ typeName ^ "ToString (x : " ^ structName ^ "." ^ typeName ^ ") : string = " ^ typeName ^ "ToStringI \"\" x\n"))
| _ => ())
(ListPair.zip (List.tabulate (length decls, fn i => i), decls))
val _ = TextIO.output(out, "end\n")
val _ = OS.Process.exit OS.Process.success
|
