Mercurial > urweb

annotate src/monoize.sml @ 109:813e5a52063d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Remove closure conversion in favor of zany fun with modules, which also replaces 'page'
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 10:17:06 -0400
parents d101cb1efe55
children 3739af9e727a
rev   line source
adamc@25 1 (* Copyright (c) 2008, Adam Chlipala
adamc@25 2 * All rights reserved.
adamc@25 3 *
adamc@25 4 * Redistribution and use in source and binary forms, with or without
adamc@25 5 * modification, are permitted provided that the following conditions are met:
adamc@25 6 *
adamc@25 7 * - Redistributions of source code must retain the above copyright notice,
adamc@25 8 * this list of conditions and the following disclaimer.
adamc@25 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@25 10 * this list of conditions and the following disclaimer in the documentation
adamc@25 11 * and/or other materials provided with the distribution.
adamc@25 12 * - The names of contributors may not be used to endorse or promote products
adamc@25 13 * derived from this software without specific prior written permission.
adamc@25 14 *
adamc@25 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@25 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@25 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@25 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@25 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@25 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@25 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@25 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@25 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@25 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@25 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@25 26 *)
adamc@25 27
adamc@25 28 structure Monoize :> MONOIZE = struct
adamc@25 29
adamc@25 30 structure E = ErrorMsg
adamc@25 31 structure Env = CoreEnv
adamc@25 32
adamc@25 33 structure L = Core
adamc@25 34 structure L' = Mono
adamc@25 35
adamc@25 36 val dummyTyp = (L'.TNamed 0, E.dummySpan)
adamc@25 37
adamc@25 38 fun monoName env (all as (c, loc)) =
adamc@25 39 let
adamc@25 40 fun poly () =
adamc@25 41 (E.errorAt loc "Unsupported name constructor";
adamc@25 42 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
adamc@25 43 "")
adamc@25 44 in
adamc@25 45 case c of
adamc@25 46 L.CName s => s
adamc@25 47 | _ => poly ()
adamc@25 48 end
adamc@25 49
adamc@25 50 fun monoType env (all as (c, loc)) =
adamc@25 51 let
adamc@25 52 fun poly () =
adamc@25 53 (E.errorAt loc "Unsupported type constructor";
adamc@25 54 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
adamc@25 55 dummyTyp)
adamc@25 56 in
adamc@25 57 case c of
adamc@25 58 L.TFun (c1, c2) => (L'.TFun (monoType env c1, monoType env c2), loc)
adamc@25 59 | L.TCFun _ => poly ()
adamc@25 60 | L.TRecord (L.CRecord ((L.KType, _), xcs), _) =>
adamc@25 61 (L'.TRecord (map (fn (x, t) => (monoName env x, monoType env t)) xcs), loc)
adamc@25 62 | L.TRecord _ => poly ()
adamc@25 63
adamc@94 64 | L.CApp ((L.CFfi ("Basis", "xml"), _), _) => (L'.TFfi ("Basis", "string"), loc)
adamc@94 65
adamc@25 66 | L.CRel _ => poly ()
adamc@25 67 | L.CNamed n => (L'.TNamed n, loc)
adamc@51 68 | L.CFfi mx => (L'.TFfi mx, loc)
adamc@25 69 | L.CApp _ => poly ()
adamc@25 70 | L.CAbs _ => poly ()
adamc@25 71
adamc@25 72 | L.CName _ => poly ()
adamc@25 73
adamc@25 74 | L.CRecord _ => poly ()
adamc@25 75 | L.CConcat _ => poly ()
adamc@69 76 | L.CFold _ => poly ()
adamc@87 77 | L.CUnit => poly ()
adamc@25 78 end
adamc@25 79
adamc@25 80 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
adamc@25 81
adamc@105 82 fun attrifyExp (e, tAll as (t, loc)) =
adamc@105 83 case t of
adamc@106 84 L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", "attrifyString", [e]), loc)
adamc@105 85 | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", "attrifyInt", [e]), loc)
adamc@105 86 | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", "attrifyFloat", [e]), loc)
adamc@105 87 | _ => (E.errorAt loc "Don't know how to encode attribute type";
adamc@105 88 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
adamc@105 89 dummyExp)
adamc@105 90
adamc@25 91 fun monoExp env (all as (e, loc)) =
adamc@25 92 let
adamc@25 93 fun poly () =
adamc@25 94 (E.errorAt loc "Unsupported expression";
adamc@25 95 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
adamc@25 96 dummyExp)
adamc@25 97 in
adamc@25 98 case e of
adamc@25 99 L.EPrim p => (L'.EPrim p, loc)
adamc@25 100 | L.ERel n => (L'.ERel n, loc)
adamc@25 101 | L.ENamed n => (L'.ENamed n, loc)
adamc@51 102 | L.EFfi mx => (L'.EFfi mx, loc)
adamc@51 103 | L.EFfiApp (m, x, es) => (L'.EFfiApp (m, x, map (monoExp env) es), loc)
adamc@94 104
adamc@94 105 | L.EApp ((L.ECApp ((L.EFfi ("Basis", "cdata"), _),
adamc@94 106 _), _), se) => monoExp env se
adamc@95 107 | L.EApp (
adamc@95 108 (L.EApp (
adamc@95 109 (L.ECApp (
adamc@95 110 (L.ECApp (
adamc@95 111 (L.ECApp (
adamc@95 112 (L.EFfi ("Basis", "join"),
adamc@95 113 _), _), _),
adamc@95 114 _), _),
adamc@95 115 _), _),
adamc@95 116 xml1), _),
adamc@95 117 xml2) => (L'.EStrcat (monoExp env xml1, monoExp env xml2), loc)
adamc@95 118
adamc@95 119 | L.EApp (
adamc@95 120 (L.EApp (
adamc@104 121 (L.EApp (
adamc@95 122 (L.ECApp (
adamc@104 123 (L.ECApp (
adamc@104 124 (L.ECApp (
adamc@104 125 (L.ECApp (
adamc@104 126 (L.EFfi ("Basis", "tag"),
adamc@104 127 _), _), _), _), _), _), _), _), _),
adamc@104 128 attrs), _),
adamc@95 129 tag), _),
adamc@95 130 xml) =>
adamc@95 131 let
adamc@95 132 fun getTag (e, _) =
adamc@95 133 case e of
adamc@95 134 L.EFfi ("Basis", tag) => tag
adamc@95 135 | _ => (E.errorAt loc "Non-constant XML tag";
adamc@95 136 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
adamc@95 137 "")
adamc@95 138
adamc@95 139 val tag = getTag tag
adamc@95 140
adamc@104 141 val attrs = monoExp env attrs
adamc@104 142
adamc@104 143 val tagStart =
adamc@104 144 case #1 attrs of
adamc@104 145 L'.ERecord xes =>
adamc@104 146 let
adamc@104 147 fun lowercaseFirst "" = ""
adamc@104 148 | lowercaseFirst s = str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@104 149
adamc@104 150 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
adamc@104 151 in
adamc@105 152 foldl (fn ((x, e, t), s) =>
adamc@104 153 let
adamc@104 154 val xp = " " ^ lowercaseFirst x ^ "=\""
adamc@104 155 in
adamc@104 156 (L'.EStrcat (s,
adamc@104 157 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
adamc@105 158 (L'.EStrcat (attrifyExp (e, t),
adamc@104 159 (L'.EPrim (Prim.String "\""), loc)),
adamc@104 160 loc)),
adamc@104 161 loc)), loc)
adamc@104 162 end)
adamc@104 163 s xes
adamc@104 164 end
adamc@104 165 | _ => raise Fail "Attributes!"
adamc@104 166
adamc@95 167 fun normal () =
adamc@104 168 (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
adamc@95 169 (L'.EStrcat (monoExp env xml,
adamc@95 170 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])), loc)), loc)),
adamc@95 171 loc)
adamc@104 172
adamc@104 173
adamc@95 174 in
adamc@95 175 case xml of
adamc@95 176 (L.EApp ((L.ECApp ((L.EFfi ("Basis", "cdata"), _),
adamc@95 177 _), _), (L.EPrim (Prim.String s), _)), _) =>
adamc@95 178 if CharVector.all Char.isSpace s then
adamc@104 179 (L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc)
adamc@95 180 else
adamc@95 181 normal ()
adamc@95 182 | _ => normal ()
adamc@95 183 end
adamc@94 184
adamc@25 185 | L.EApp (e1, e2) => (L'.EApp (monoExp env e1, monoExp env e2), loc)
adamc@26 186 | L.EAbs (x, dom, ran, e) =>
adamc@26 187 (L'.EAbs (x, monoType env dom, monoType env ran, monoExp (Env.pushERel env x dom) e), loc)
adamc@25 188 | L.ECApp _ => poly ()
adamc@25 189 | L.ECAbs _ => poly ()
adamc@25 190
adamc@29 191 | L.ERecord xes => (L'.ERecord (map (fn (x, e, t) => (monoName env x, monoExp env e, monoType env t)) xes), loc)
adamc@25 192 | L.EField (e, x, _) => (L'.EField (monoExp env e, monoName env x), loc)
adamc@73 193 | L.EFold _ => poly ()
adamc@102 194 | L.EWrite e => (L'.EWrite (monoExp env e), loc)
adamc@25 195 end
adamc@25 196
adamc@25 197 fun monoDecl env (all as (d, loc)) =
adamc@25 198 let
adamc@25 199 fun poly () =
adamc@25 200 (E.errorAt loc "Unsupported declaration";
adamc@25 201 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
adamc@25 202 NONE)
adamc@25 203 in
adamc@25 204 case d of
adamc@25 205 L.DCon _ => NONE
adamc@109 206 | L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s,
adamc@109 207 (L'.DVal (x, n, monoType env t, monoExp env e, s), loc))
adamc@109 208 | L.DExport n => SOME (env, (L'.DExport n, loc))
adamc@25 209 end
adamc@25 210
adamc@25 211 fun monoize env ds =
adamc@25 212 let
adamc@25 213 val (_, ds) = List.foldl (fn (d, (env, ds)) =>
adamc@25 214 case monoDecl env d of
adamc@25 215 NONE => (env, ds)
adamc@25 216 | SOME (env, d) => (env, d :: ds)) (env, []) ds
adamc@25 217 in
adamc@25 218 rev ds
adamc@25 219 end
adamc@25 220
adamc@25 221 end