Mercurial > urweb

comparison src/elaborate.sml @ 913:b26823138bf8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix structure wildification to take concrete con decls into account
author Adam Chlipala <adamc@hcoop.net>
date Tue, 25 Aug 2009 17:12:21 -0400
parents 6d9538ce94d8
children 6dd122f10c0c
comparison
equal deleted inserted replaced
912:771449d8b411 913:b26823138bf8
3084 | L'.CConcat (c1, c2) => 3084 | L'.CConcat (c1, c2) =>
3085 (case (decompileCon env c1, decompileCon env c2) of 3085 (case (decompileCon env c1, decompileCon env c2) of
3086 (SOME c1, SOME c2) => SOME (L.CConcat (c1, c2), loc) 3086 (SOME c1, SOME c2) => SOME (L.CConcat (c1, c2), loc)
3087 | _ => NONE) 3087 | _ => NONE)
3088 | L'.CUnit => SOME (L.CUnit, loc) 3088 | L'.CUnit => SOME (L.CUnit, loc)
3089 | L'.CUnif (_, _, _, ref (SOME c)) => decompileCon env c
3089 3090
3090 | _ => NONE 3091 | _ => NONE
3091 3092
3092 val (neededC, constraints, neededV, _) = 3093 val (neededC, constraints, neededV, _) =
3093 foldl (fn ((sgi, loc), (neededC, constraints, neededV, env')) => 3094 foldl (fn ((sgi, loc), (neededC, constraints, neededV, env')) =>
3094 let 3095 let
3095 val (needed, constraints, neededV) = 3096 val (needed, constraints, neededV) =
3096 case sgi of 3097 case sgi of
3097 L'.SgiConAbs (x, _, k) => (SM.insert (neededC, x, k), constraints, neededV) 3098 L'.SgiCon (x, _, k, c) => (SM.insert (neededC, x, (k, SOME c)),
3099 constraints, neededV)
3100 | L'.SgiConAbs (x, _, k) => (SM.insert (neededC, x, (k, NONE)), constraints, neededV)
3098 | L'.SgiConstraint cs => (neededC, (env', cs, loc) :: constraints, neededV) 3101 | L'.SgiConstraint cs => (neededC, (env', cs, loc) :: constraints, neededV)
3099 3102
3100 | L'.SgiVal (x, _, t) => 3103 | L'.SgiVal (x, _, t) =>
3101 let 3104 let
3102 fun default () = (neededC, constraints, neededV) 3105 fun default () = (neededC, constraints, neededV)
3152 val ds' = 3155 val ds' =
3153 case SM.listItemsi neededC of 3156 case SM.listItemsi neededC of
3154 [] => ds' 3157 [] => ds'
3155 | xs => 3158 | xs =>
3156 let 3159 let
3157 val ds'' = map (fn (x, k) => 3160 val ds'' = map (fn (x, (k, co)) =>
3158 let 3161 let
3159 val k = 3162 val k =
3160 case decompileKind k of 3163 case decompileKind k of
3161 NONE => (L.KWild, #2 str) 3164 NONE => (L.KWild, #2 str)
3162 | SOME k => k 3165 | SOME k => k
3166
3163 val cwild = (L.CWild k, #2 str) 3167 val cwild = (L.CWild k, #2 str)
3168 val c =
3169 case co of
3170 NONE => cwild
3171 | SOME c =>
3172 case decompileCon env c of
3173 NONE => cwild
3174 | SOME c' => c'
3164 in 3175 in
3165 (L.DCon (x, NONE, cwild), #2 str) 3176 (L.DCon (x, NONE, c), #2 str)
3166 end) xs 3177 end) xs
3167 in 3178 in
3168 ds'' @ ds' 3179 ds'' @ ds'
3169 end 3180 end
3170 in 3181 in