summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/mono_fm.sig22
-rw-r--r--src/mono_fm.sml115
-rw-r--r--src/mono_fooify.sig38
-rw-r--r--src/mono_fooify.sml317
-rw-r--r--src/monoize.sml206
-rw-r--r--src/sources4
6 files changed, 377 insertions, 325 deletions
diff --git a/src/mono_fm.sig b/src/mono_fm.sig
deleted file mode 100644
index a72a5da7..00000000
--- a/src/mono_fm.sig
+++ /dev/null
@@ -1,22 +0,0 @@
-signature MONO_FM = sig
- type t
-
- type vr = string * int * Mono.typ * Mono.exp * string
-
- datatype foo_kind =
- Attr
- | Url
-
- val empty : int -> t
-
- val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int
- val lookupList : t -> foo_kind -> Mono.typ -> (int -> t -> vr * t) -> t * int
- val enter : t -> t
- val decls : t -> Mono.decl list
-
- val freshName : t -> int * t
-
- (* TODO: don't expose raw references if possible. *)
- val nextPvar : int ref
- val postMonoize : t ref
-end
diff --git a/src/mono_fm.sml b/src/mono_fm.sml
deleted file mode 100644
index d7e9e001..00000000
--- a/src/mono_fm.sml
+++ /dev/null
@@ -1,115 +0,0 @@
-(* TODO: better name than "fm"? *)
-structure MonoFm : MONO_FM = struct
-
-open Mono
-
-type vr = string * int * typ * exp * string
-
-datatype foo_kind =
- Attr
- | Url
-
-structure IM = IntBinaryMap
-
-structure M = BinaryMapFn(struct
- type ord_key = foo_kind
- fun compare x =
- case x of
- (Attr, Attr) => EQUAL
- | (Attr, _) => LESS
- | (_, Attr) => GREATER
-
- | (Url, Url) => EQUAL
- end)
-
-structure TM = BinaryMapFn(struct
- type ord_key = typ
- val compare = MonoUtil.Typ.compare
- end)
-
-type t = {
- count : int,
- map : int IM.map M.map,
- listMap : int TM.map M.map,
- decls : vr list
-}
-
-val nextPvar = ref 0
-
-fun empty count = {
- count = count,
- map = M.empty,
- listMap = M.empty,
- decls = []
-}
-
-fun chooseNext count =
- let
- val n = !nextPvar
- in
- if count < n then
- (count, count+1)
- else
- (nextPvar := n + 1;
- (n, n+1))
- end
-
-fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
-fun freshName {count, map, listMap, decls} =
- let
- val (next, count) = chooseNext count
- in
- (next, {count = count , map = map, listMap = listMap, decls = decls})
- end
-fun decls ({decls, ...} : t) =
- case decls of
- [] => []
- | _ => [(DValRec decls, ErrorMsg.dummySpan)]
-
-fun lookup (t as {count, map, listMap, decls}) k n thunk =
- let
- val im = Option.getOpt (M.find (map, k), IM.empty)
- in
- case IM.find (im, n) of
- NONE =>
- let
- val n' = count
- val (d, {count, map, listMap, decls}) =
- thunk count {count = count + 1,
- map = M.insert (map, k, IM.insert (im, n, n')),
- listMap = listMap,
- decls = decls}
- in
- ({count = count,
- map = map,
- listMap = listMap,
- decls = d :: decls}, n')
- end
- | SOME n' => (t, n')
- end
-
-fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
- let
- val tm = Option.getOpt (M.find (listMap, k), TM.empty)
- in
- case TM.find (tm, tp) of
- NONE =>
- let
- val n' = count
- val (d, {count, map, listMap, decls}) =
- thunk count {count = count + 1,
- map = map,
- listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
- decls = decls}
- in
- ({count = count,
- map = map,
- listMap = listMap,
- decls = d :: decls}, n')
- end
- | SOME n' => (t, n')
- end
-
-val postMonoize : t ref = ref (empty 0)
-
-end
diff --git a/src/mono_fooify.sig b/src/mono_fooify.sig
new file mode 100644
index 00000000..9eb8038b
--- /dev/null
+++ b/src/mono_fooify.sig
@@ -0,0 +1,38 @@
+signature MONO_FOOIFY = sig
+
+(* TODO: don't expose raw references if possible. *)
+val nextPvar : int ref
+val pvarDefs : ((string * int * (string * int * Mono.typ option) list) list) ref
+
+datatype foo_kind = Attr | Url
+
+structure Fm : sig
+ type t
+
+ type vr = string * int * Mono.typ * Mono.exp * string
+
+ val empty : int -> t
+
+ val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int
+ val lookupList : t -> foo_kind -> Mono.typ -> (int -> t -> vr * t) -> t * int
+ val enter : t -> t
+ val decls : t -> Mono.decl list
+
+ val freshName : t -> int * t
+
+ (* Set at the end of [Monoize]. *)
+ val canonical : t ref
+end
+
+(* General form used in [Monoize]. *)
+val fooifyExp : foo_kind
+ -> (int -> Mono.typ * string)
+ -> (int -> string * (string * int * Mono.typ option) list)
+ -> Fm.t
+ -> Mono.exp * Mono.typ
+ -> Mono.exp * Fm.t
+
+(* Easy-to-use special case used in [Sqlcache]. *)
+val urlify : MonoEnv.env -> Mono.exp * Mono.typ -> Mono.exp
+
+end
diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml
new file mode 100644
index 00000000..d7cb9f59
--- /dev/null
+++ b/src/mono_fooify.sml
@@ -0,0 +1,317 @@
+structure MonoFooify :> MONO_FOOIFY = struct
+
+open Mono
+
+datatype foo_kind =
+ Attr
+ | Url
+
+val nextPvar = ref 0
+val pvarDefs = ref ([] : (string * int * (string * int * typ option) list) list)
+
+structure Fm = struct
+
+type vr = string * int * typ * exp * string
+
+structure IM = IntBinaryMap
+
+structure M = BinaryMapFn(struct
+ type ord_key = foo_kind
+ fun compare x =
+ case x of
+ (Attr, Attr) => EQUAL
+ | (Attr, _) => LESS
+ | (_, Attr) => GREATER
+
+ | (Url, Url) => EQUAL
+ end)
+
+structure TM = BinaryMapFn(struct
+ type ord_key = typ
+ val compare = MonoUtil.Typ.compare
+ end)
+
+type t = {
+ count : int,
+ map : int IM.map M.map,
+ listMap : int TM.map M.map,
+ decls : vr list
+}
+
+fun empty count = {
+ count = count,
+ map = M.empty,
+ listMap = M.empty,
+ decls = []
+}
+
+fun chooseNext count =
+ let
+ val n = !nextPvar
+ in
+ if count < n then
+ (count, count+1)
+ else
+ (nextPvar := n + 1;
+ (n, n+1))
+ end
+
+fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
+fun freshName {count, map, listMap, decls} =
+ let
+ val (next, count) = chooseNext count
+ in
+ (next, {count = count , map = map, listMap = listMap, decls = decls})
+ end
+fun decls ({decls, ...} : t) =
+ case decls of
+ [] => []
+ | _ => [(DValRec decls, ErrorMsg.dummySpan)]
+
+fun lookup (t as {count, map, listMap, decls}) k n thunk =
+ let
+ val im = Option.getOpt (M.find (map, k), IM.empty)
+ in
+ case IM.find (im, n) of
+ NONE =>
+ let
+ val n' = count
+ val (d, {count, map, listMap, decls}) =
+ thunk count {count = count + 1,
+ map = M.insert (map, k, IM.insert (im, n, n')),
+ listMap = listMap,
+ decls = decls}
+ in
+ ({count = count,
+ map = map,
+ listMap = listMap,
+ decls = d :: decls}, n')
+ end
+ | SOME n' => (t, n')
+ end
+
+fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
+ let
+ val tm = Option.getOpt (M.find (listMap, k), TM.empty)
+ in
+ case TM.find (tm, tp) of
+ NONE =>
+ let
+ val n' = count
+ val (d, {count, map, listMap, decls}) =
+ thunk count {count = count + 1,
+ map = map,
+ listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
+ decls = decls}
+ in
+ ({count = count,
+ map = map,
+ listMap = listMap,
+ decls = d :: decls}, n')
+ end
+ | SOME n' => (t, n')
+ end
+
+(* Has to be set at the end of [Monoize]. *)
+val canonical = ref (empty 0 : t)
+
+end
+
+fun fk2s fk =
+ case fk of
+ Attr => "attr"
+ | Url => "url"
+
+fun capitalize s =
+ if s = "" then
+ s
+ else
+ str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
+
+structure E = ErrorMsg
+
+val dummyExp = (EPrim (Prim.Int 0), E.dummySpan)
+
+fun fooifyExp fk lookupENamed lookupDatatype =
+ let
+ fun fooify fm (e, tAll as (t, loc)) =
+ case #1 e of
+ EClosure (fnam, [(ERecord [], _)]) =>
+ let
+ val (_, s) = lookupENamed fnam
+ in
+ ((EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
+ end
+ | EClosure (fnam, args) =>
+ let
+ val (ft, s) = lookupENamed fnam
+ fun attrify (args, ft, e, fm) =
+ case (args, ft) of
+ ([], _) => (e, fm)
+ | (arg :: args, (TFun (t, ft), _)) =>
+ let
+ val (arg', fm) = fooify fm (arg, t)
+ in
+ attrify (args, ft,
+ (EStrcat (e,
+ (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
+ arg'), loc)), loc),
+ fm)
+ end
+ | _ => (E.errorAt loc "Type mismatch encoding attribute";
+ (e, fm))
+ in
+ attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
+ end
+ | _ =>
+ case t of
+ TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
+ | TFfi (m, x) => ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
+
+ | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
+ | TRecord ((x, t) :: xts) =>
+ let
+ val (se, fm) = fooify fm ((EField (e, x), loc), t)
+ in
+ foldl (fn ((x, t), (se, fm)) =>
+ let
+ val (se', fm) = fooify fm ((EField (e, x), loc), t)
+ in
+ ((EStrcat (se,
+ (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
+ se'), loc)), loc),
+ fm)
+ end) (se, fm) xts
+ end
+
+ | TDatatype (i, ref (dk, _)) =>
+ let
+ fun makeDecl n fm =
+ let
+ val (x, xncs) =
+ case ListUtil.search (fn (x, i', xncs) =>
+ if i' = i then
+ SOME (x, xncs)
+ else
+ NONE) (!pvarDefs) of
+ NONE => lookupDatatype i
+ | SOME v => v
+
+ val (branches, fm) =
+ ListUtil.foldlMap
+ (fn ((x, n, to), fm) =>
+ case to of
+ NONE =>
+ (((PCon (dk, PConVar n, NONE), loc),
+ (EPrim (Prim.String (Prim.Normal, x)), loc)),
+ fm)
+ | SOME t =>
+ let
+ val (arg, fm) = fooify fm ((ERel 0, loc), t)
+ in
+ (((PCon (dk, PConVar n, SOME (PVar ("a", t), loc)), loc),
+ (EStrcat ((EPrim (Prim.String (Prim.Normal, x ^ "/")), loc),
+ arg), loc)),
+ fm)
+ end)
+ fm xncs
+
+ val dom = tAll
+ val ran = (TFfi ("Basis", "string"), loc)
+ in
+ ((fk2s fk ^ "ify_" ^ x,
+ n,
+ (TFun (dom, ran), loc),
+ (EAbs ("x",
+ dom,
+ ran,
+ (ECase ((ERel 0, loc),
+ branches,
+ {disc = dom,
+ result = ran}), loc)), loc),
+ ""),
+ fm)
+ end
+
+ val (fm, n) = Fm.lookup fm fk i makeDecl
+ in
+ ((EApp ((ENamed n, loc), e), loc), fm)
+ end
+
+ | TOption t =>
+ let
+ val (body, fm) = fooify fm ((ERel 0, loc), t)
+ in
+ ((ECase (e,
+ [((PNone t, loc),
+ (EPrim (Prim.String (Prim.Normal, "None")), loc)),
+
+ ((PSome (t, (PVar ("x", t), loc)), loc),
+ (EStrcat ((EPrim (Prim.String (Prim.Normal, "Some/")), loc),
+ body), loc))],
+ {disc = tAll,
+ result = (TFfi ("Basis", "string"), loc)}), loc),
+ fm)
+ end
+
+ | TList t =>
+ let
+ fun makeDecl n fm =
+ let
+ val rt = (TRecord [("1", t), ("2", (TList t, loc))], loc)
+ val (arg, fm) = fooify fm ((ERel 0, loc), rt)
+
+ val branches = [((PNone rt, loc),
+ (EPrim (Prim.String (Prim.Normal, "Nil")), loc)),
+ ((PSome (rt, (PVar ("a", rt), loc)), loc),
+ (EStrcat ((EPrim (Prim.String (Prim.Normal, "Cons/")), loc),
+ arg), loc))]
+
+ val dom = tAll
+ val ran = (TFfi ("Basis", "string"), loc)
+ in
+ ((fk2s fk ^ "ify_list",
+ n,
+ (TFun (dom, ran), loc),
+ (EAbs ("x",
+ dom,
+ ran,
+ (ECase ((ERel 0, loc),
+ branches,
+ {disc = dom,
+ result = ran}), loc)), loc),
+ ""),
+ fm)
+ end
+
+ val (fm, n) = Fm.lookupList fm fk t makeDecl
+ in
+ ((EApp ((ENamed n, loc), e), loc), fm)
+ end
+
+ | _ => (E.errorAt loc "Don't know how to encode attribute/URL type";
+ Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
+ (dummyExp, fm))
+ in
+ fooify
+ end
+
+fun urlify env expTyp =
+ let
+ val (exp, fm) =
+ fooifyExp
+ Url
+ (fn n =>
+ let
+ val (_, t, _, s) = MonoEnv.lookupENamed env n
+ in
+ (t, s)
+ end)
+ (fn n => MonoEnv.lookupDatatype env n)
+ (!Fm.canonical)
+ expTyp
+ in
+ Fm.canonical := fm;
+ exp
+ end
+end
diff --git a/src/monoize.sml b/src/monoize.sml
index 4bd3aff2..f92d7511 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -50,9 +50,9 @@ structure RM = BinaryMapFn(struct
(L'.TRecord r2, E.dummySpan))
end)
-val nextPvar = MonoFm.nextPvar
+val nextPvar = MonoFooify.nextPvar
val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map)
-val pvarDefs = ref ([] : (string * int * (string * int * L'.typ option) list) list)
+val pvarDefs = MonoFooify.pvarDefs
val pvarOldDefs = ref ([] : (int * (string * int * L.con option) list) list)
fun choosePvar () =
@@ -374,192 +374,26 @@ fun monoType env =
val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
-structure Fm = MonoFm
-
-fun fk2s fk =
- case fk of
- Fm.Attr => "attr"
- | Fm.Url => "url"
-
-fun capitalize s =
- if s = "" then
- s
- else
- str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
+structure Fm = MonoFooify.Fm
fun fooifyExp fk env =
- let
- fun fooify fm (e, tAll as (t, loc)) =
- case #1 e of
- L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
- let
- val (_, _, _, s) = Env.lookupENamed env fnam
- in
- ((L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
- end
- | L'.EClosure (fnam, args) =>
- let
- val (_, ft, _, s) = Env.lookupENamed env fnam
- val ft = monoType env ft
-
- fun attrify (args, ft, e, fm) =
- case (args, ft) of
- ([], _) => (e, fm)
- | (arg :: args, (L'.TFun (t, ft), _)) =>
- let
- val (arg', fm) = fooify fm (arg, t)
- in
- attrify (args, ft,
- (L'.EStrcat (e,
- (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc),
- arg'), loc)), loc),
- fm)
- end
- | _ => (E.errorAt loc "Type mismatch encoding attribute";
- (e, fm))
- in
- attrify (args, ft, (L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
- end
- | _ =>
- case t of
- L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm)
- | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
-
- | L'.TRecord [] => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm)
- | L'.TRecord ((x, t) :: xts) =>
- let
- val (se, fm) = fooify fm ((L'.EField (e, x), loc), t)
- in
- foldl (fn ((x, t), (se, fm)) =>
- let
- val (se', fm) = fooify fm ((L'.EField (e, x), loc), t)
- in
- ((L'.EStrcat (se,
- (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc),
- se'), loc)), loc),
- fm)
- end) (se, fm) xts
- end
-
- | L'.TDatatype (i, ref (dk, _)) =>
- let
- fun makeDecl n fm =
- let
- val (x, xncs) =
- case ListUtil.search (fn (x, i', xncs) =>
- if i' = i then
- SOME (x, xncs)
- else
- NONE) (!pvarDefs) of
- NONE =>
- let
- val (x, _, xncs) = Env.lookupDatatype env i
- in
- (x, map (fn (x, n, c) => (x, n, Option.map (monoType env) c)) xncs)
- end
- | SOME v => v
-
- val (branches, fm) =
- ListUtil.foldlMap
- (fn ((x, n, to), fm) =>
- case to of
- NONE =>
- (((L'.PCon (dk, L'.PConVar n, NONE), loc),
- (L'.EPrim (Prim.String (Prim.Normal, x)), loc)),
- fm)
- | SOME t =>
- let
- val (arg, fm) = fooify fm ((L'.ERel 0, loc), t)
- in
- (((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc),
- (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, x ^ "/")), loc),
- arg), loc)),
- fm)
- end)
- fm xncs
-
- val dom = tAll
- val ran = (L'.TFfi ("Basis", "string"), loc)
- in
- ((fk2s fk ^ "ify_" ^ x,
- n,
- (L'.TFun (dom, ran), loc),
- (L'.EAbs ("x",
- dom,
- ran,
- (L'.ECase ((L'.ERel 0, loc),
- branches,
- {disc = dom,
- result = ran}), loc)), loc),
- ""),
- fm)
- end
-
- val (fm, n) = Fm.lookup fm fk i makeDecl
- in
- ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
- end
-
- | L'.TOption t =>
- let
- val (body, fm) = fooify fm ((L'.ERel 0, loc), t)
- in
- ((L'.ECase (e,
- [((L'.PNone t, loc),
- (L'.EPrim (Prim.String (Prim.Normal, "None")), loc)),
-
- ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
- (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Some/")), loc),
- body), loc))],
- {disc = tAll,
- result = (L'.TFfi ("Basis", "string"), loc)}), loc),
- fm)
- end
-
- | L'.TList t =>
- let
- fun makeDecl n fm =
- let
- val rt = (L'.TRecord [("1", t), ("2", (L'.TList t, loc))], loc)
- val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt)
-
- val branches = [((L'.PNone rt, loc),
- (L'.EPrim (Prim.String (Prim.Normal, "Nil")), loc)),
- ((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc),
- (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Cons/")), loc),
- arg), loc))]
-
- val dom = tAll
- val ran = (L'.TFfi ("Basis", "string"), loc)
- in
- ((fk2s fk ^ "ify_list",
- n,
- (L'.TFun (dom, ran), loc),
- (L'.EAbs ("x",
- dom,
- ran,
- (L'.ECase ((L'.ERel 0, loc),
- branches,
- {disc = dom,
- result = ran}), loc)), loc),
- ""),
- fm)
- end
-
- val (fm, n) = Fm.lookupList fm fk t makeDecl
- in
- ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
- end
-
- | _ => (E.errorAt loc "Don't know how to encode attribute/URL type";
- Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
- (dummyExp, fm))
- in
- fooify
- end
+ MonoFooify.fooifyExp
+ fk
+ (fn n =>
+ let
+ val (_, t, _, s) = Env.lookupENamed env n
+ in
+ (monoType env t, s)
+ end)
+ (fn n =>
+ let
+ val (x, _, xncs) = Env.lookupDatatype env n
+ in
+ (x, map (fn (x, n, c) => (x, n, Option.map (monoType env) c)) xncs)
+ end)
-val attrifyExp = fooifyExp Fm.Attr
-val urlifyExp = fooifyExp Fm.Url
+val attrifyExp = fooifyExp MonoFooify.Attr
+val urlifyExp = fooifyExp MonoFooify.Url
val urlifiedUnit =
let
@@ -4667,7 +4501,7 @@ fun monoize env file =
pvars := RM.empty;
pvarDefs := [];
pvarOldDefs := [];
- Fm.postMonoize := fm;
+ Fm.canonical := fm;
(rev ds, [])
end
diff --git a/src/sources b/src/sources
index e6a361ce..1303b46e 100644
--- a/src/sources
+++ b/src/sources
@@ -168,8 +168,8 @@ $(SRC)/mono_env.sml
$(SRC)/mono_print.sig
$(SRC)/mono_print.sml
-$(SRC)/mono_fm.sig
-$(SRC)/mono_fm.sml
+$(SRC)/mono_fooify.sig
+$(SRC)/mono_fooify.sml
$(SRC)/sql.sig
$(SRC)/sql.sml
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-01 02:51:32 +0000