summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/ur/list.ur10
-rw-r--r--lib/ur/list.urs1
-rw-r--r--src/core_print.sml10
-rw-r--r--src/core_util.sml8
-rw-r--r--src/expl_print.sml16
-rw-r--r--src/unpoly.sml9
-rw-r--r--tests/pathmap.ur3
7 files changed, 42 insertions, 15 deletions
diff --git a/lib/ur/list.ur b/lib/ur/list.ur
index 5310c810..ecec2bec 100644
--- a/lib/ur/list.ur
+++ b/lib/ur/list.ur
@@ -29,3 +29,13 @@ fun mp (a ::: Type) (b ::: Type) f =
in
mp' []
end
+
+fun mapX (a ::: Type) (ctx ::: {Unit}) f =
+ let
+ fun mapX' ls =
+ case ls of
+ [] => <xml/>
+ | x :: ls => <xml>{f x}{mapX' ls}</xml>
+ in
+ mapX'
+ end
diff --git a/lib/ur/list.urs b/lib/ur/list.urs
index 879648ea..e9e097d4 100644
--- a/lib/ur/list.urs
+++ b/lib/ur/list.urs
@@ -6,3 +6,4 @@ val rev : a ::: Type -> t a -> t a
val mp : a ::: Type -> b ::: Type -> (a -> b) -> t a -> t b
+val mapX : a ::: Type -> ctx ::: {Unit} -> (a -> xml ctx [] []) -> t a -> xml ctx [] []
diff --git a/src/core_print.sml b/src/core_print.sml
index 971aa4b4..e9d8951e 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -198,12 +198,18 @@ fun p_con_named env n =
fun p_patCon env pc =
case pc of
PConVar n => p_con_named env n
- | PConFfi {mod = m, con, arg, ...} =>
+ | PConFfi {mod = m, con, arg, params, ...} =>
if !debug then
box [string "FFIC[",
case arg of
NONE => box []
- | SOME t => p_con env t,
+ | SOME t =>
+ let
+ val k = (KType, ErrorMsg.dummySpan)
+ val env' = foldl (fn (x, env) => E.pushCRel env x k) env params
+ in
+ p_con env' t
+ end,
string "](",
string m,
string ".",
diff --git a/src/core_util.sml b/src/core_util.sml
index ae956121..e3ec8a1d 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -772,7 +772,13 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
| PConFfi {mod = m, datatyp, params, con, arg, kind} =>
S.map2 ((case arg of
NONE => S.return2 NONE
- | SOME c => S.map2 (mfc ctx c, SOME)),
+ | SOME c =>
+ let
+ val k = (KType, ErrorMsg.dummySpan)
+ val ctx' = foldl (fn (x, ctx) => bind (ctx, RelC (x, k))) ctx params
+ in
+ S.map2 (mfc ctx' c, SOME)
+ end),
fn arg' =>
PConFfi {mod = m, datatyp = datatyp, params = params,
con = con, arg = arg', kind = kind})
diff --git a/src/expl_print.sml b/src/expl_print.sml
index e6b28fea..7aa36c6d 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -219,9 +219,19 @@ fun p_pat' par env (p, _) =
| PVar (s, _) => string s
| PPrim p => Prim.p_t p
| PCon (_, pc, _, NONE) => p_patCon env pc
- | PCon (_, pc, _, SOME p) => parenIf par (box [p_patCon env pc,
- space,
- p_pat' true env p])
+ | PCon (_, pc, cs, SOME p) =>
+ if !debug then
+ parenIf par (box [p_patCon env pc,
+ string "[",
+ p_list (p_con env) cs,
+ string "]",
+ space,
+ p_pat' true env p])
+ else
+ parenIf par (box [p_patCon env pc,
+ space,
+ p_pat' true env p])
+
| PRecord xps =>
box [string "{",
p_list_sep (box [string ",", space]) (fn (x, p, _) =>
diff --git a/src/unpoly.sml b/src/unpoly.sml
index 56406636..6f838392 100644
--- a/src/unpoly.sml
+++ b/src/unpoly.sml
@@ -138,14 +138,7 @@ fun exp (e, st : state) =
in
trim (t, e, cargs)
end
- | (_, _, []) =>
- (*let
- val e = foldl (fn ((_, n, n_old, _, _, _), e) =>
- unpolyNamed (n_old, ENamed n) e)
- e vis
- in*)
- SOME (t, e)
- (*end*)
+ | (_, _, []) => SOME (t, e)
| _ => NONE
in
(*Print.prefaces "specialize"
diff --git a/tests/pathmap.ur b/tests/pathmap.ur
index 2ce1f5f0..98eaad7e 100644
--- a/tests/pathmap.ur
+++ b/tests/pathmap.ur
@@ -4,5 +4,6 @@ val y = List.mp (plus 2) x
fun main () : transaction page = return <xml><body>
{[x]}<br/>
{[y]}<br/>
- {[Aux.hello]}
+ {[Aux.hello]}<br/>
+ {List.mapX (fn n => <xml>{[n]}!</xml>) x}
</body></xml>