Mercurial > urweb

annotate src/mono_util.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 2d6116de9cca
rev   line source
adamc@26 1 (* Copyright (c) 2008, Adam Chlipala
adamc@26 2 * All rights reserved.
adamc@26 3 *
adamc@26 4 * Redistribution and use in source and binary forms, with or without
adamc@26 5 * modification, are permitted provided that the following conditions are met:
adamc@26 6 *
adamc@26 7 * - Redistributions of source code must retain the above copyright notice,
adamc@26 8 * this list of conditions and the following disclaimer.
adamc@26 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@26 10 * this list of conditions and the following disclaimer in the documentation
adamc@26 11 * and/or other materials provided with the distribution.
adamc@26 12 * - The names of contributors may not be used to endorse or promote products
adamc@26 13 * derived from this software without specific prior written permission.
adamc@26 14 *
adamc@26 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@26 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@26 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@26 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@26 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@26 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@26 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@26 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@26 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@26 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@26 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@26 26 *)
adamc@26 27
adamc@26 28 structure MonoUtil :> MONO_UTIL = struct
adamc@26 29
adamc@26 30 open Mono
adamc@26 31
adamc@26 32 structure S = Search
adamc@26 33
adamc@26 34 structure Typ = struct
adamc@26 35
adamc@109 36 fun join (o1, o2) =
adamc@109 37 case o1 of
adamc@109 38 EQUAL => o2 ()
adamc@109 39 | v => v
adamc@109 40
adamc@109 41 fun joinL f (os1, os2) =
adamc@109 42 case (os1, os2) of
adamc@109 43 (nil, nil) => EQUAL
adamc@109 44 | (nil, _) => LESS
adamc@109 45 | (h1 :: t1, h2 :: t2) =>
adamc@109 46 join (f (h1, h2), fn () => joinL f (t1, t2))
adamc@109 47 | (_ :: _, nil) => GREATER
adamc@109 48
adamc@109 49 fun compare ((t1, _), (t2, _)) =
adamc@109 50 case (t1, t2) of
adamc@109 51 (TFun (d1, r1), TFun (d2, r2)) =>
adamc@109 52 join (compare (d1, d2), fn () => compare (r1, r2))
adamc@109 53 | (TRecord xts1, TRecord xts2) =>
adamc@109 54 let
adamc@109 55 val xts1 = sortFields xts1
adamc@109 56 val xts2 = sortFields xts2
adamc@109 57 in
adamc@109 58 joinL compareFields (xts1, xts2)
adamc@109 59 end
adamc@109 60 | (TNamed n1, TNamed n2) => Int.compare (n1, n2)
adamc@109 61 | (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
adamc@109 62
adamc@109 63 | (TFun _, _) => LESS
adamc@109 64 | (_, TFun _) => GREATER
adamc@109 65
adamc@109 66 | (TRecord _, _) => LESS
adamc@109 67 | (_, TRecord _) => GREATER
adamc@109 68
adamc@109 69 | (TNamed _, _) => LESS
adamc@109 70 | (_, TNamed _) => GREATER
adamc@109 71
adamc@109 72 and compareFields ((x1, t1), (x2, t2)) =
adamc@109 73 join (String.compare (x1, x2),
adamc@109 74 fn () => compare (t1, t2))
adamc@109 75
adamc@109 76 and sortFields xts = ListMergeSort.sort (fn (x, y) => compareFields (x, y) = GREATER) xts
adamc@109 77
adamc@26 78 fun mapfold fc =
adamc@26 79 let
adamc@26 80 fun mft c acc =
adamc@26 81 S.bindP (mft' c acc, fc)
adamc@26 82
adamc@26 83 and mft' (cAll as (c, loc)) =
adamc@26 84 case c of
adamc@26 85 TFun (t1, t2) =>
adamc@26 86 S.bind2 (mft t1,
adamc@26 87 fn t1' =>
adamc@26 88 S.map2 (mft t2,
adamc@26 89 fn t2' =>
adamc@26 90 (TFun (t1', t2'), loc)))
adamc@26 91 | TRecord xts =>
adamc@26 92 S.map2 (ListUtil.mapfold (fn (x, t) =>
adamc@26 93 S.map2 (mft t,
adamc@26 94 fn t' =>
adamc@26 95 (x, t')))
adamc@26 96 xts,
adamc@26 97 fn xts' => (TRecord xts', loc))
adamc@26 98 | TNamed _ => S.return2 cAll
adamc@51 99 | TFfi _ => S.return2 cAll
adamc@26 100 in
adamc@26 101 mft
adamc@26 102 end
adamc@26 103
adamc@26 104 fun map typ c =
adamc@26 105 case mapfold (fn c => fn () => S.Continue (typ c, ())) c () of
adamc@26 106 S.Return () => raise Fail "Mono_util.Typ.map"
adamc@26 107 | S.Continue (c, ()) => c
adamc@26 108
adamc@26 109 fun fold typ s c =
adamc@26 110 case mapfold (fn c => fn s => S.Continue (c, typ (c, s))) c s of
adamc@26 111 S.Continue (_, s) => s
adamc@26 112 | S.Return _ => raise Fail "MonoUtil.Typ.fold: Impossible"
adamc@26 113
adamc@26 114 fun exists typ k =
adamc@26 115 case mapfold (fn c => fn () =>
adamc@26 116 if typ c then
adamc@26 117 S.Return ()
adamc@26 118 else
adamc@26 119 S.Continue (c, ())) k () of
adamc@26 120 S.Return _ => true
adamc@26 121 | S.Continue _ => false
adamc@26 122
adamc@26 123 end
adamc@26 124
adamc@26 125 structure Exp = struct
adamc@26 126
adamc@26 127 datatype binder =
adamc@26 128 NamedT of string * int * typ option
adamc@26 129 | RelE of string * typ
adamc@109 130 | NamedE of string * int * typ * exp option * string
adamc@26 131
adamc@26 132 fun mapfoldB {typ = fc, exp = fe, bind} =
adamc@26 133 let
adamc@26 134 val mft = Typ.mapfold fc
adamc@26 135
adamc@26 136 fun mfe ctx e acc =
adamc@26 137 S.bindP (mfe' ctx e acc, fe ctx)
adamc@26 138
adamc@26 139 and mfe' ctx (eAll as (e, loc)) =
adamc@26 140 case e of
adamc@26 141 EPrim _ => S.return2 eAll
adamc@26 142 | ERel _ => S.return2 eAll
adamc@26 143 | ENamed _ => S.return2 eAll
adamc@51 144 | EFfi _ => S.return2 eAll
adamc@51 145 | EFfiApp (m, x, es) =>
adamc@51 146 S.map2 (ListUtil.mapfold (fn e => mfe ctx e) es,
adamc@51 147 fn es' =>
adamc@51 148 (EFfiApp (m, x, es'), loc))
adamc@26 149 | EApp (e1, e2) =>
adamc@26 150 S.bind2 (mfe ctx e1,
adamc@26 151 fn e1' =>
adamc@26 152 S.map2 (mfe ctx e2,
adamc@26 153 fn e2' =>
adamc@26 154 (EApp (e1', e2'), loc)))
adamc@26 155 | EAbs (x, dom, ran, e) =>
adamc@26 156 S.bind2 (mft dom,
adamc@26 157 fn dom' =>
adamc@26 158 S.bind2 (mft ran,
adamc@26 159 fn ran' =>
adamc@26 160 S.map2 (mfe (bind (ctx, RelE (x, dom'))) e,
adamc@26 161 fn e' =>
adamc@26 162 (EAbs (x, dom', ran', e'), loc))))
adamc@26 163
adamc@26 164 | ERecord xes =>
adamc@29 165 S.map2 (ListUtil.mapfold (fn (x, e, t) =>
adamc@29 166 S.bind2 (mfe ctx e,
adamc@26 167 fn e' =>
adamc@29 168 S.map2 (mft t,
adamc@29 169 fn t' =>
adamc@29 170 (x, e', t'))))
adamc@26 171 xes,
adamc@26 172 fn xes' =>
adamc@26 173 (ERecord xes', loc))
adamc@26 174 | EField (e, x) =>
adamc@26 175 S.map2 (mfe ctx e,
adamc@26 176 fn e' =>
adamc@26 177 (EField (e', x), loc))
adamc@94 178
adamc@94 179 | EStrcat (e1, e2) =>
adamc@94 180 S.bind2 (mfe ctx e1,
adamc@94 181 fn e1' =>
adamc@94 182 S.map2 (mfe ctx e2,
adamc@94 183 fn e2' =>
adamc@94 184 (EStrcat (e1', e2'), loc)))
adamc@102 185
adamc@102 186 | EWrite e =>
adamc@102 187 S.map2 (mfe ctx e,
adamc@102 188 fn e' =>
adamc@102 189 (EWrite e', loc))
adamc@106 190
adamc@106 191 | ESeq (e1, e2) =>
adamc@106 192 S.bind2 (mfe ctx e1,
adamc@106 193 fn e1' =>
adamc@106 194 S.map2 (mfe ctx e2,
adamc@106 195 fn e2' =>
adamc@106 196 (ESeq (e1', e2'), loc)))
adamc@26 197 in
adamc@26 198 mfe
adamc@26 199 end
adamc@26 200
adamc@26 201 fun mapfold {typ = fc, exp = fe} =
adamc@26 202 mapfoldB {typ = fc,
adamc@26 203 exp = fn () => fe,
adamc@26 204 bind = fn ((), _) => ()} ()
adamc@26 205
adamc@26 206 fun mapB {typ, exp, bind} ctx e =
adamc@26 207 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@26 208 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
adamc@26 209 bind = bind} ctx e () of
adamc@26 210 S.Continue (e, ()) => e
adamc@26 211 | S.Return _ => raise Fail "MonoUtil.Exp.mapB: Impossible"
adamc@26 212
adamc@26 213 fun map {typ, exp} e =
adamc@26 214 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@26 215 exp = fn e => fn () => S.Continue (exp e, ())} e () of
adamc@26 216 S.Return () => raise Fail "Mono_util.Exp.map"
adamc@26 217 | S.Continue (e, ()) => e
adamc@26 218
adamc@26 219 fun fold {typ, exp} s e =
adamc@26 220 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 221 exp = fn e => fn s => S.Continue (e, exp (e, s))} e s of
adamc@26 222 S.Continue (_, s) => s
adamc@26 223 | S.Return _ => raise Fail "MonoUtil.Exp.fold: Impossible"
adamc@26 224
adamc@26 225 fun exists {typ, exp} k =
adamc@26 226 case mapfold {typ = fn c => fn () =>
adamc@26 227 if typ c then
adamc@26 228 S.Return ()
adamc@26 229 else
adamc@26 230 S.Continue (c, ()),
adamc@26 231 exp = fn e => fn () =>
adamc@26 232 if exp e then
adamc@26 233 S.Return ()
adamc@26 234 else
adamc@26 235 S.Continue (e, ())} k () of
adamc@26 236 S.Return _ => true
adamc@26 237 | S.Continue _ => false
adamc@26 238
adamc@26 239 end
adamc@26 240
adamc@26 241 structure Decl = struct
adamc@26 242
adamc@26 243 datatype binder = datatype Exp.binder
adamc@26 244
adamc@26 245 fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
adamc@26 246 let
adamc@26 247 val mft = Typ.mapfold fc
adamc@26 248
adamc@26 249 val mfe = Exp.mapfoldB {typ = fc, exp = fe, bind = bind}
adamc@26 250
adamc@26 251 fun mfd ctx d acc =
adamc@26 252 S.bindP (mfd' ctx d acc, fd ctx)
adamc@26 253
adamc@26 254 and mfd' ctx (dAll as (d, loc)) =
adamc@26 255 case d of
adamc@109 256 DVal (x, n, t, e, s) =>
adamc@26 257 S.bind2 (mft t,
adamc@26 258 fn t' =>
adamc@26 259 S.map2 (mfe ctx e,
adamc@26 260 fn e' =>
adamc@109 261 (DVal (x, n, t', e', s), loc)))
adamc@109 262 | DExport _ => S.return2 dAll
adamc@26 263 in
adamc@26 264 mfd
adamc@26 265 end
adamc@26 266
adamc@26 267 fun mapfold {typ = fc, exp = fe, decl = fd} =
adamc@26 268 mapfoldB {typ = fc,
adamc@26 269 exp = fn () => fe,
adamc@26 270 decl = fn () => fd,
adamc@26 271 bind = fn ((), _) => ()} ()
adamc@26 272
adamc@26 273 fun fold {typ, exp, decl} s d =
adamc@26 274 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 275 exp = fn e => fn s => S.Continue (e, exp (e, s)),
adamc@26 276 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
adamc@26 277 S.Continue (_, s) => s
adamc@26 278 | S.Return _ => raise Fail "MonoUtil.Decl.fold: Impossible"
adamc@26 279
adamc@26 280 end
adamc@26 281
adamc@26 282 structure File = struct
adamc@26 283
adamc@26 284 datatype binder = datatype Exp.binder
adamc@26 285
adamc@26 286 fun mapfoldB (all as {bind, ...}) =
adamc@26 287 let
adamc@26 288 val mfd = Decl.mapfoldB all
adamc@26 289
adamc@26 290 fun mff ctx ds =
adamc@26 291 case ds of
adamc@26 292 nil => S.return2 nil
adamc@26 293 | d :: ds' =>
adamc@26 294 S.bind2 (mfd ctx d,
adamc@26 295 fn d' =>
adamc@26 296 let
adamc@100 297 val ctx' =
adamc@26 298 case #1 d' of
adamc@109 299 DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
adamc@109 300 | DExport _ => ctx
adamc@26 301 in
adamc@26 302 S.map2 (mff ctx' ds',
adamc@26 303 fn ds' =>
adamc@26 304 d' :: ds')
adamc@26 305 end)
adamc@26 306 in
adamc@26 307 mff
adamc@26 308 end
adamc@26 309
adamc@26 310 fun mapfold {typ = fc, exp = fe, decl = fd} =
adamc@26 311 mapfoldB {typ = fc,
adamc@26 312 exp = fn () => fe,
adamc@26 313 decl = fn () => fd,
adamc@26 314 bind = fn ((), _) => ()} ()
adamc@26 315
adamc@26 316 fun mapB {typ, exp, decl, bind} ctx ds =
adamc@26 317 case mapfoldB {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@26 318 exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
adamc@26 319 decl = fn ctx => fn d => fn () => S.Continue (decl ctx d, ()),
adamc@26 320 bind = bind} ctx ds () of
adamc@26 321 S.Continue (ds, ()) => ds
adamc@26 322 | S.Return _ => raise Fail "MonoUtil.File.mapB: Impossible"
adamc@26 323
adamc@96 324 fun map {typ, exp, decl} e =
adamc@96 325 case mapfold {typ = fn c => fn () => S.Continue (typ c, ()),
adamc@96 326 exp = fn e => fn () => S.Continue (exp e, ()),
adamc@96 327 decl = fn d => fn () => S.Continue (decl d, ())} e () of
adamc@96 328 S.Return () => raise Fail "Mono_util.File.map"
adamc@96 329 | S.Continue (e, ()) => e
adamc@96 330
adamc@26 331 fun fold {typ, exp, decl} s d =
adamc@26 332 case mapfold {typ = fn c => fn s => S.Continue (c, typ (c, s)),
adamc@26 333 exp = fn e => fn s => S.Continue (e, exp (e, s)),
adamc@26 334 decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
adamc@26 335 S.Continue (_, s) => s
adamc@26 336 | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible"
adamc@26 337
adamc@26 338 end
adamc@26 339
adamc@26 340 end