Mercurial > urweb

annotate src/explify.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 f0f59e918cac
children e3041657d653
rev   line source
adamc@38 1 (* Copyright (c) 2008, Adam Chlipala
adamc@38 2 * All rights reserved.
adamc@38 3 *
adamc@38 4 * Redistribution and use in source and binary forms, with or without
adamc@38 5 * modification, are permitted provided that the following conditions are met:
adamc@38 6 *
adamc@38 7 * - Redistributions of source code must retain the above copyright notice,
adamc@38 8 * this list of conditions and the following disclaimer.
adamc@38 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@38 10 * this list of conditions and the following disclaimer in the documentation
adamc@38 11 * and/or other materials provided with the distribution.
adamc@38 12 * - The names of contributors may not be used to endorse or promote products
adamc@38 13 * derived from this software without specific prior written permission.
adamc@38 14 *
adamc@38 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@38 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@38 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@38 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@38 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@38 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@38 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@38 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@38 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@38 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@38 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@38 26 *)
adamc@38 27
adamc@38 28 structure Explify :> EXPLIFY = struct
adamc@38 29
adamc@38 30 structure EM = ErrorMsg
adamc@38 31 structure L = Elab
adamc@38 32 structure L' = Expl
adamc@38 33
adamc@38 34 fun explifyKind (k, loc) =
adamc@38 35 case k of
adamc@38 36 L.KType => (L'.KType, loc)
adamc@38 37 | L.KArrow (k1, k2) => (L'.KArrow (explifyKind k1, explifyKind k2), loc)
adamc@38 38 | L.KName => (L'.KName, loc)
adamc@38 39 | L.KRecord k => (L'.KRecord (explifyKind k), loc)
adamc@38 40
adamc@87 41 | L.KUnit => (L'.KUnit, loc)
adamc@82 42
adamc@38 43 | L.KError => raise Fail ("explifyKind: KError at " ^ EM.spanToString loc)
adamc@76 44 | L.KUnif (_, _, ref (SOME k)) => explifyKind k
adamc@38 45 | L.KUnif _ => raise Fail ("explifyKind: KUnif at " ^ EM.spanToString loc)
adamc@38 46
adamc@38 47 fun explifyCon (c, loc) =
adamc@38 48 case c of
adamc@38 49 L.TFun (t1, t2) => (L'.TFun (explifyCon t1, explifyCon t2), loc)
adamc@38 50 | L.TCFun (_, x, k, t) => (L'.TCFun (x, explifyKind k, explifyCon t), loc)
adamc@85 51 | L.TDisjoint (_, _, c) => explifyCon c
adamc@38 52 | L.TRecord c => (L'.TRecord (explifyCon c), loc)
adamc@38 53
adamc@38 54 | L.CRel n => (L'.CRel n, loc)
adamc@38 55 | L.CNamed n => (L'.CNamed n, loc)
adamc@38 56 | L.CModProj (m, ms, x) => (L'.CModProj (m, ms, x), loc)
adamc@38 57
adamc@38 58 | L.CApp (c1, c2) => (L'.CApp (explifyCon c1, explifyCon c2), loc)
adamc@38 59 | L.CAbs (x, k, c) => (L'.CAbs (x, explifyKind k, explifyCon c), loc)
adamc@85 60 | L.CDisjoint (_, _, c) => explifyCon c
adamc@38 61
adamc@38 62 | L.CName s => (L'.CName s, loc)
adamc@38 63
adamc@38 64 | L.CRecord (k, xcs) => (L'.CRecord (explifyKind k, map (fn (c1, c2) => (explifyCon c1, explifyCon c2)) xcs), loc)
adamc@38 65 | L.CConcat (c1, c2) => (L'.CConcat (explifyCon c1, explifyCon c2), loc)
adamc@68 66 | L.CFold (dom, ran) => (L'.CFold (explifyKind dom, explifyKind ran), loc)
adamc@38 67
adamc@87 68 | L.CUnit => (L'.CUnit, loc)
adamc@82 69
adamc@38 70 | L.CError => raise Fail ("explifyCon: CError at " ^ EM.spanToString loc)
adamc@76 71 | L.CUnif (_, _, _, ref (SOME c)) => explifyCon c
adamc@38 72 | L.CUnif _ => raise Fail ("explifyCon: CUnif at " ^ EM.spanToString loc)
adamc@38 73
adamc@38 74 fun explifyExp (e, loc) =
adamc@38 75 case e of
adamc@38 76 L.EPrim p => (L'.EPrim p, loc)
adamc@38 77 | L.ERel n => (L'.ERel n, loc)
adamc@38 78 | L.ENamed n => (L'.ENamed n, loc)
adamc@38 79 | L.EModProj (m, ms, x) => (L'.EModProj (m, ms, x), loc)
adamc@38 80 | L.EApp (e1, e2) => (L'.EApp (explifyExp e1, explifyExp e2), loc)
adamc@38 81 | L.EAbs (x, dom, ran, e1) => (L'.EAbs (x, explifyCon dom, explifyCon ran, explifyExp e1), loc)
adamc@38 82 | L.ECApp (e1, c) => (L'.ECApp (explifyExp e1, explifyCon c), loc)
adamc@38 83 | L.ECAbs (_, x, k, e1) => (L'.ECAbs (x, explifyKind k, explifyExp e1), loc)
adamc@38 84
adamc@38 85 | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => (explifyCon c, explifyExp e, explifyCon t)) xes), loc)
adamc@38 86 | L.EField (e1, c, {field, rest}) => (L'.EField (explifyExp e1, explifyCon c,
adamc@38 87 {field = explifyCon field, rest = explifyCon rest}), loc)
adamc@72 88 | L.EFold k => (L'.EFold (explifyKind k), loc)
adamc@38 89
adamc@38 90 | L.EError => raise Fail ("explifyExp: EError at " ^ EM.spanToString loc)
adamc@38 91
adamc@38 92 fun explifySgi (sgi, loc) =
adamc@38 93 case sgi of
adamc@88 94 L.SgiConAbs (x, n, k) => SOME (L'.SgiConAbs (x, n, explifyKind k), loc)
adamc@88 95 | L.SgiCon (x, n, k, c) => SOME (L'.SgiCon (x, n, explifyKind k, explifyCon c), loc)
adamc@88 96 | L.SgiVal (x, n, c) => SOME (L'.SgiVal (x, n, explifyCon c), loc)
adamc@88 97 | L.SgiStr (x, n, sgn) => SOME (L'.SgiStr (x, n, explifySgn sgn), loc)
adamc@88 98 | L.SgiSgn (x, n, sgn) => SOME (L'.SgiSgn (x, n, explifySgn sgn), loc)
adamc@88 99 | L.SgiConstraint _ => NONE
adamc@38 100
adamc@38 101 and explifySgn (sgn, loc) =
adamc@38 102 case sgn of
adamc@88 103 L.SgnConst sgis => (L'.SgnConst (List.mapPartial explifySgi sgis), loc)
adamc@38 104 | L.SgnVar n => (L'.SgnVar n, loc)
adamc@45 105 | L.SgnFun (m, n, dom, ran) => (L'.SgnFun (m, n, explifySgn dom, explifySgn ran), loc)
adamc@45 106 | L.SgnWhere (sgn, x, c) => (L'.SgnWhere (explifySgn sgn, x, explifyCon c), loc)
adamc@64 107 | L.SgnProj x => (L'.SgnProj x, loc)
adamc@38 108 | L.SgnError => raise Fail ("explifySgn: SgnError at " ^ EM.spanToString loc)
adamc@38 109
adamc@38 110 fun explifyDecl (d, loc : EM.span) =
adamc@38 111 case d of
adamc@88 112 L.DCon (x, n, k, c) => SOME (L'.DCon (x, n, explifyKind k, explifyCon c), loc)
adamc@88 113 | L.DVal (x, n, t, e) => SOME (L'.DVal (x, n, explifyCon t, explifyExp e), loc)
adamc@38 114
adamc@88 115 | L.DSgn (x, n, sgn) => SOME (L'.DSgn (x, n, explifySgn sgn), loc)
adamc@88 116 | L.DStr (x, n, sgn, str) => SOME (L'.DStr (x, n, explifySgn sgn, explifyStr str), loc)
adamc@88 117 | L.DFfiStr (x, n, sgn) => SOME (L'.DFfiStr (x, n, explifySgn sgn), loc)
adamc@88 118 | L.DConstraint (c1, c2) => NONE
adamc@109 119 | L.DExport (en, sgn, str) => SOME (L'.DExport (en, explifySgn sgn, explifyStr str), loc)
adamc@38 120
adamc@38 121 and explifyStr (str, loc) =
adamc@38 122 case str of
adamc@88 123 L.StrConst ds => (L'.StrConst (List.mapPartial explifyDecl ds), loc)
adamc@38 124 | L.StrVar n => (L'.StrVar n, loc)
adamc@38 125 | L.StrProj (str, s) => (L'.StrProj (explifyStr str, s), loc)
adamc@45 126 | L.StrFun (m, n, dom, ran, str) => (L'.StrFun (m, n, explifySgn dom, explifySgn ran, explifyStr str), loc)
adamc@45 127 | L.StrApp (str1, str2) => (L'.StrApp (explifyStr str1, explifyStr str2), loc)
adamc@38 128 | L.StrError => raise Fail ("explifyStr: StrError at " ^ EM.spanToString loc)
adamc@38 129
adamc@88 130 val explify = List.mapPartial explifyDecl
adamc@38 131
adamc@38 132 end