Mercurial > urweb

changeset 1735:ec47f49c6aa3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
In simplifying constructors for error messages, unfold constructor synonyms from modules
author Adam Chlipala <adam@chlipala.net>
date Wed, 02 May 2012 08:23:30 -0400
parents d2b3fada532e
children 7ec8dab190a7
files src/elab_ops.sml tests/tcsimp.ur
diffstat 2 files changed, 18 insertions(+), 1 deletions(-) [+]
line wrap: on
line diff
--- a/src/elab_ops.sml	Sun Apr 29 20:37:45 2012 -0400
+++ b/src/elab_ops.sml	Wed May 02 08:23:30 2012 -0400
@@ -336,7 +336,21 @@
         (case E.lookupCNamed env xn of
              (_, _, SOME c') => reduceCon env c'
            | _ => cAll)
-      | CModProj _ => cAll
+      | CModProj (n, ms, x) =>
+        let
+            val (_, sgn) = E.lookupStrNamed env n
+            val (str, sgn) = foldl (fn (m, (str, sgn)) =>
+                                       case E.projectStr env {sgn = sgn, str = str, field = m} of
+                                           NONE => raise Fail "reduceCon: Unknown substructure"
+                                         | SOME sgn => ((StrProj (str, m), loc), sgn))
+                                   ((StrVar n, loc), sgn) ms
+        in
+            case E.projectCon env {sgn = sgn, str = str, field = x} of
+                NONE => raise Fail "reduceCon: kindof: Unknown con in structure"
+              | SOME (_, NONE) => cAll
+              | SOME (_, SOME c) => reduceCon env c
+        end
+
       | CApp (c1, c2) =>
         let
             val c1 = reduceCon env c1
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/tcsimp.ur	Wed May 02 08:23:30 2012 -0400
@@ -0,0 +1,3 @@
+val x : $(mapU string [A, B]) = {A = "hi", B = "bye"}
+
+val y = show x