Mercurial > urweb

comparison src/monoize.sml @ 95:274116d1a4cd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Monoizing joins and tags
author Adam Chlipala <adamc@hcoop.net>
date Thu, 03 Jul 2008 17:53:28 -0400
parents 40d146f467c5
children f0f59e918cac
comparison
equal deleted inserted replaced
94:40d146f467c5 95:274116d1a4cd
93 | L.EFfi mx => (L'.EFfi mx, loc) 93 | L.EFfi mx => (L'.EFfi mx, loc)
94 | L.EFfiApp (m, x, es) => (L'.EFfiApp (m, x, map (monoExp env) es), loc) 94 | L.EFfiApp (m, x, es) => (L'.EFfiApp (m, x, map (monoExp env) es), loc)
95 95
96 | L.EApp ((L.ECApp ((L.EFfi ("Basis", "cdata"), _), 96 | L.EApp ((L.ECApp ((L.EFfi ("Basis", "cdata"), _),
97 _), _), se) => monoExp env se 97 _), _), se) => monoExp env se
98 | L.EApp (
99 (L.EApp (
100 (L.ECApp (
101 (L.ECApp (
102 (L.ECApp (
103 (L.EFfi ("Basis", "join"),
104 _), _), _),
105 _), _),
106 _), _),
107 xml1), _),
108 xml2) => (L'.EStrcat (monoExp env xml1, monoExp env xml2), loc)
109
110 | L.EApp (
111 (L.EApp (
112 (L.ECApp (
113 (L.ECApp (
114 (L.EFfi ("Basis", "tag"),
115 _), _), _),
116 _), _),
117 tag), _),
118 xml) =>
119 let
120 fun getTag (e, _) =
121 case e of
122 L.EFfi ("Basis", tag) => tag
123 | _ => (E.errorAt loc "Non-constant XML tag";
124 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
125 "")
126
127 val tag = getTag tag
128
129 fun normal () =
130 (L'.EStrcat ((L'.EPrim (Prim.String (String.concat ["<", tag, ">"])), loc),
131 (L'.EStrcat (monoExp env xml,
132 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])), loc)), loc)),
133 loc)
134 in
135 case xml of
136 (L.EApp ((L.ECApp ((L.EFfi ("Basis", "cdata"), _),
137 _), _), (L.EPrim (Prim.String s), _)), _) =>
138 if CharVector.all Char.isSpace s then
139 (L'.EPrim (Prim.String (String.concat ["<", tag, "/>"])), loc)
140 else
141 normal ()
142 | _ => normal ()
143 end
98 144
99 | L.EApp (e1, e2) => (L'.EApp (monoExp env e1, monoExp env e2), loc) 145 | L.EApp (e1, e2) => (L'.EApp (monoExp env e1, monoExp env e2), loc)
100 | L.EAbs (x, dom, ran, e) => 146 | L.EAbs (x, dom, ran, e) =>
101 (L'.EAbs (x, monoType env dom, monoType env ran, monoExp (Env.pushERel env x dom) e), loc) 147 (L'.EAbs (x, monoType env dom, monoType env ran, monoExp (Env.pushERel env x dom) e), loc)
102 | L.ECApp _ => poly () 148 | L.ECApp _ => poly ()