-val configRoot = "/home/adamc/domtool"
+val configRoot = "/home/adamc/cvs/domtool2/lib"
+val resultRoot = "/home/adamc/domtool"
val configRoot : string
(* Root directory for a directory hierarchy corresponding to domain structure,
* where each node contains files related to that domain's configuration. *)
+
+val resultRoot : string
+(* Root directory for a directory hierarchy corresponding to domain structure,
+ * where each node contains Domtool-generated result files for that domain. *)
--- /dev/null
+{{E-mail aliases (AKA, redirects)}}
+
+extern type emailUser;
+{{A valid username to appear before the "@" in an e-mail address}}
+
+extern type email;
+{{A valid e-mail address.
+ It may also be a username only, in which case it is interpreted as a local
+ user's mailbox.}}
+
+extern type aliasSource;
+{{An e-mail recipient whose mail you want to redirect}}
+extern val userSource : emailUser -> aliasSource;
+{{The part appear before the "@" in your desired source address}}
+extern val defaultSource : aliasSource;
+{{Matches any mail to this domain that doesn't match any other rule, with the
+ exception of systemwide usernames like UNIX users.}}
+extern val catchAllSource : aliasSource;
+{{Matches any mail to this domain that doesn't match any other rule, even
+ for systemwide usernames.}}
+
+extern type aliasTarget;
+{{A place to redirect messages}}
+extern val addressTarget : email -> aliasTarget;
+{{Redirect to this e-mail address.}}
+extern val addressesTarget : [email] -> aliasTarget;
+{{Redirect to all of these addresses.}}
+extern val dropTarget : aliasTarget;
+{{Silently delete all mail to the associated source.}}
+
+extern val aliasPrim : aliasSource -> aliasTarget -> [Domain];
+{{Request redirection of all mail from the source to the target.}
+
+val alias = \user -> \email -> aliasPrim (userSource user) (addressTarget email);
+{{Redirect mail for the user at the current domain to the e-mail address.}}
+val aliasMulti = \user -> \emails -> aliasPrim (userSource user) (addressesTarget emails);
+{{Redirect mail for the user at the current domain to all of the e-mail
+ addresses listed.}}
+val aliasDrop = \user -> aliasPrim (userSource user) dropTarget;
+{{Silently delete mail to the user at the current domain.}}
+
+val defaultAlias = \email -> aliasPrim defaultSource (addressTarget email);
+{{When a message to the current domain doesn't match any other alias, and it
+ doesn't match any systemwide username, send it to this e-mail address
+val catchAllAlias = \email -> aliasPrim catchAllSource (addressTarget email);
+{{When a message to the current domain doesn't match any other alias, send it
+ to this e-mail address, even if it matches a systemwide username.}}
--- /dev/null
+extern type int;
+extern type string;
--- /dev/null
+{{Configuring shared daemons with respect to a particular Internet domain name}}
+
+extern type domain;
+{{An Internet domain name}}
+
+context Domain;
+{{Configuration directives specific to an Internet domain}}
+
+extern val domain : domain -> Domain => [Root];
+{{Configure a domain to which you have access rights.}}
DExternType of string
| DExternVal of string * typ
| DVal of string * typ option * exp
+ | DContext of string
type decl = decl' * string option * position
-type file = decl list * exp option
+type file = string option * decl list * exp option
end
val elems = foldr (fn (piece, elems) =>
let
val elems = piece :: elems
- val path = String.concatWith "/" (Config.configRoot :: rev elems)
+ val path = String.concatWith "/" (Config.resultRoot :: rev elems)
in
(if Posix.FileSys.ST.isDir
(Posix.FileSys.stat path) then
elems
end) [] toks
in
- String.concatWith "/" (Config.configRoot :: rev ("" :: elems))
+ String.concatWith "/" (Config.resultRoot :: rev ("" :: elems))
end
val _ = Env.container_one "domain"
alias.sig
alias.sml
+order.sig
+order.sml
+
main.sig
main.sml
| LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
| EQ | COMMA | BSLASH | SEMI | LET | IN | END
| ROOT
- | EXTERN | TYPE | VAL | WITH | WHERE
+ | EXTERN | TYPE | VAL | WITH | WHERE | CONTEXT
%nonterm
file of file
%%
-file : decls expOpt (decls, expOpt)
+file : docOpt decls expOpt (docOpt, decls, expOpt)
decls : ([])
- | decl SEMI decls (decl :: decls)
+ | decl decls (decl :: decls)
-decl : decl' docOpt (decl', docOpt, (decl'left, docOptright))
+decl : decl' SEMI docOpt (decl', docOpt, (decl'left, docOptright))
decl' : EXTERN TYPE SYMBOL (DExternType SYMBOL)
| EXTERN VAL SYMBOL COLON typ (DExternVal (SYMBOL, typ))
| VAL SYMBOL EQ exp (DVal (SYMBOL, NONE, exp))
| VAL SYMBOL COLON typ EQ exp (DVal (SYMBOL, SOME typ, exp))
+ | CONTEXT CSYMBOL (DContext CSYMBOL)
docOpt : (NONE)
| DOC (SOME DOC)
<INITIAL> "extern" => (Tokens.EXTERN (yypos, yypos + size yytext));
<INITIAL> "type" => (Tokens.TYPE (yypos, yypos + size yytext));
<INITIAL> "val" => (Tokens.VAL (yypos, yypos + size yytext));
+<INITIAL> "context" => (Tokens.CONTEXT (yypos, yypos + size yytext));
<INITIAL> "Root" => (Tokens.ROOT (yypos, yypos + size yytext));
val bindType : env -> string -> env
val bindVal : env -> string * Ast.typ * Ast.exp option -> env
+ val bindContext : env -> string -> env
val lookupType : env -> string -> bool
val lookupVal : env -> string -> Ast.typ option
val lookupEquation : env -> string -> Ast.exp option
+ val lookupContext : env -> string -> bool
+ val types : env -> Ast.StringSet.set
+ val vals : env -> Ast.StringSet.set
+ val contexts : env -> Ast.StringSet.set
end
fun container_one name args (f, g) = registerContainer (name, one name args f, g)
-type env = SS.set * (typ * exp option) SM.map
-val empty : env = (SS.add (SS.singleton "int", "string"),
- SM.empty)
+type env = SS.set * (typ * exp option) SM.map * SS.set
+val empty : env = (SS.empty, SM.empty, SS.empty)
-fun lookupType (ts, _) name = SS.member (ts, name)
-fun lookupVal (_, vs) name =
+fun lookupType (ts, _, _) name = SS.member (ts, name)
+fun lookupVal (_, vs, _) name =
case SM.find (vs, name) of
NONE => NONE
| SOME (t, _) => SOME t
-fun lookupEquation (_, vs) name =
+fun lookupEquation (_, vs, _) name =
case SM.find (vs, name) of
NONE => NONE
| SOME (_, eqo) => eqo
+fun lookupContext (_, _, cs) name = SS.member (cs, name)
-fun bindType (ts, vs) name = (SS.add (ts, name), vs)
-fun bindVal (ts, vs) (name, t, eqo) = (ts, SM.insert (vs, name, (t, eqo)))
+fun bindType (ts, vs, cs) name = (SS.add (ts, name), vs, cs)
+fun bindVal (ts, vs, cs) (name, t, eqo) = (ts, SM.insert (vs, name, (t, eqo)), cs)
+fun bindContext (ts, vs, cs) name = (ts, vs, SS.add (cs, name))
+
+fun types (ts, _, _) = ts
+fun vals (_, vs, _) = SM.foldli (fn (name, _, vs) => SS.add (vs, name)) SS.empty vs
+fun contexts (_, _, cs) = cs
end
()
else
case prog of
- (_, SOME body) =>
+ (_, _, SOME body) =>
let
val body' = Reduce.reduceExp G' body
in
()
else
case prog of
- (_, SOME body) =>
+ (_, _, SOME body) =>
let
val body' = Reduce.reduceExp G' body
in
--- /dev/null
+(* HCoop Domtool (http://hcoop.sourceforge.net/)
+ * Copyright (c) 2006, Adam Chlipala
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+ *)
+
+(* Topological sorting of source files to take dependencies into account *)
+
+signature ORDER = sig
+
+ val order : string list -> string list
+
+end
--- /dev/null
+(* HCoop Domtool (http://hcoop.sourceforge.net/)
+ * Copyright (c) 2006, Adam Chlipala
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+ *)
+
+(* Topological sorting of source files to take dependencies into account *)
+
+structure Order :> ORDER = struct
+
+open Ast
+
+structure SS = StringSet
+structure SM = StringMap
+
+fun predNeeded G (p, _) =
+ case p of
+ CRoot => SS.empty
+ | CConst s =>
+ if Env.lookupContext G s then
+ SS.empty
+ else
+ SS.singleton s
+ | CPrefix p => predNeeded G p
+ | CNot p => predNeeded G p
+ | CAnd (p1, p2) => SS.union (predNeeded G p1, predNeeded G p2)
+
+fun unionCT ((c1, t1), (c2, t2)) = (SS.union (c1, c2), SS.union (t1, t2))
+
+fun typNeeded G (t, _) =
+ case t of
+ TBase s =>
+ if Env.lookupType G s then
+ (SS.empty, SS.empty)
+ else
+ (SS.empty, SS.singleton s)
+ | TList t => typNeeded G t
+ | TArrow (t1, t2) => unionCT (typNeeded G t1, typNeeded G t2)
+ | TAction (p, d, r) =>
+ let
+ val recordNeeded = SM.foldl
+ (fn (t, ss) => unionCT (ss, typNeeded G t))
+ in
+ recordNeeded (recordNeeded (predNeeded G p, SS.empty) d) r
+ end
+ | TNested (p, t) => unionCT ((predNeeded G p, SS.empty),
+ typNeeded G t)
+
+ | TError => raise Fail "TError during dependency analysis"
+ | TUnif _ => raise Fail "TUnif during dependency analysis"
+
+val empty = ((SS.empty, SS.empty), SS.empty)
+
+fun unionCTE (((c1, t1), v1), ((c2, t2), v2)) =
+ ((SS.union (c1, c2),
+ SS.union (t1, t2)),
+ SS.union (v1, v2))
+
+val dt = (TError, ErrorMsg.dummyLoc)
+
+fun expNeeded G (e, _) =
+ case e of
+ EInt _ => ((SS.empty,
+ if Env.lookupType G "int" then
+ SS.empty
+ else
+ SS.singleton "int"),
+ SS.empty)
+ | EString _ => ((SS.empty,
+ if Env.lookupType G "string" then
+ SS.empty
+ else
+ SS.singleton "string"),
+ SS.empty)
+ | EList es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
+ empty es
+
+ | ELam (x, to, e) =>
+ let
+ val G' = Env.bindVal G (x, dt, NONE)
+ in
+ case to of
+ NONE => expNeeded G' e
+ | SOME t => unionCTE ((typNeeded G t, SS.empty),
+ expNeeded G' e)
+ end
+ | EVar x =>
+ (case Env.lookupVal G x of
+ NONE => ((SS.empty, SS.empty), SS.singleton x)
+ | _ => empty)
+ | EApp (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
+
+ | ESkip => empty
+ | ESet (_, e) => expNeeded G e
+ | EGet (x, _, e) => expNeeded (Env.bindVal G (x, dt, NONE)) e
+ | ESeq es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
+ empty es
+ | ELocal (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
+ | EWith (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
+
+fun declNeeded G (d, _, _) =
+ case d of
+ DExternType name => (Env.bindType G name, empty)
+ | DExternVal (name, t) => (Env.bindVal G (name, dt, NONE),
+ (typNeeded G t, SS.empty))
+ | DVal (name, to, e) => (Env.bindVal G (name, dt, NONE),
+ case to of
+ NONE => expNeeded G e
+ | SOME t => unionCTE ((typNeeded G t, SS.empty),
+ expNeeded G e))
+ | DContext name => (Env.bindContext G name, empty)
+
+fun fileSig (_, ds, eo) =
+ let
+ val (G', needed) = foldl
+ (fn (d, (G, needed)) =>
+ let
+ val (G', needed') = declNeeded G d
+ in
+ (G', unionCTE (needed, needed'))
+ end)
+ (Env.empty, empty) ds
+
+ val needed =
+ case eo of
+ NONE => needed
+ | SOME e => unionCTE (needed,
+ expNeeded G' e)
+ in
+ (((Env.contexts G', Env.types G'), Env.vals G'),
+ needed)
+ end
+
+fun printSig ((cs, ts), vs) =
+ (print "Contexts:";
+ SS.app (fn s => (print " "; print s; print ";")) cs;
+ print "\n Types:";
+ SS.app (fn s => (print " "; print s; print ";")) ts;
+ print "\n Values:";
+ SS.app (fn s => (print " "; print s; print ";")) vs;
+ print "\n")
+
+fun mergeProvide kind fname (m1, m2) =
+ SS.foldl (fn (name, provide) =>
+ (case SM.find (provide, name) of
+ NONE => ()
+ | SOME fname' => ErrorMsg.error NONE (String.concat ["Files ",
+ fname',
+ " and ",
+ fname,
+ " both provide ",
+ kind,
+ " ",
+ name]);
+ SM.insert (provide, name, fname)))
+ m1 m2
+
+fun order fnames =
+ let
+ fun doFile fname =
+ let
+ val file = Parse.parse fname
+ val (provide, require) = fileSig file
+ in
+ print "\nFile ";
+ print fname;
+ print "\nPROVIDE:\n";
+ printSig provide;
+ print "\nREQUIRE:\n";
+ printSig require
+ end
+
+ fun doFile (fname, (provideC, provideT, provideV, require)) =
+ let
+ val file = Parse.parse fname
+ val (((provideC', provideT'), provideV'),
+ require') = fileSig file
+ in
+ (mergeProvide "context" fname (provideC, provideC'),
+ mergeProvide "type" fname (provideT, provideT'),
+ mergeProvide "value" fname (provideV, provideV'),
+ SM.insert (require, fname, require'))
+ end
+
+ val (provideC, provideT, provideV, require) =
+ foldl doFile (SM.empty, SM.empty, SM.empty, SM.empty) fnames
+
+ val require = SM.mapi (fn (fname, ((rc, rt), rv)) =>
+ let
+ fun consider (kind, provide) =
+ SS.foldl (fn (name, need) =>
+ case SM.find (provide, name) of
+ NONE => (ErrorMsg.error NONE
+ ("File "
+ ^ fname
+ ^ " uses undefined "
+ ^ kind
+ ^ " "
+ ^ name);
+ need)
+ | SOME fname' =>
+ SS.add (need, fname'))
+
+ val need = consider ("context", provideC)
+ SS.empty rc
+ val need = consider ("type", provideT)
+ need rt
+ val need = consider ("value", provideV)
+ need rv
+ in
+ need
+ end) require
+
+ fun loop (ready, waiting, order) =
+ case SS.find (fn _ => true) ready of
+ NONE =>
+ if SM.numItems waiting = 0 then
+ rev order
+ else
+ (ErrorMsg.error NONE "Cyclic dependency in source files";
+ order)
+ | SOME next =>
+ let
+ val (ready', waiting') =
+ SM.foldli (fn (fname, requires, (ready', waiting')) =>
+ let
+ val requires' = SS.delete (requires, next)
+ handle NotFound => requires
+ in
+ if SS.numItems requires' = 0 then
+ (SS.add (ready', fname),
+ waiting')
+ else
+ (ready',
+ SM.insert (waiting', fname, requires'))
+ end)
+ (SS.delete (ready, next), SM.empty) waiting
+ in
+ loop (ready', waiting', next :: order)
+ end
+
+ val (ready, waiting) =
+ SM.foldli (fn (fname, requires, (ready, waiting)) =>
+ if SS.numItems requires = 0 then
+ (SS.add (ready, fname),
+ waiting)
+ else
+ (ready,
+ SM.insert (waiting, fname, requires)))
+ (SS.empty, SM.empty) require
+ in
+ (*SM.appi (fn (name, fname) => print ("Context " ^ name ^ " in " ^ fname ^ "\n")) provideC;
+ SM.appi (fn (name, fname) => print ("Type " ^ name ^ " in " ^ fname ^ "\n")) provideT;
+ SM.appi (fn (name, fname) => print ("Value " ^ name ^ " in " ^ fname ^ "\n")) provideV;*)
+
+ (*SM.appi (fn (fname, requires) =>
+ (print fname;
+ print " requires:";
+ SS.app (fn fname' => (print " "; print fname')) requires;
+ print "\n")) require;*)
+
+ loop (ready, waiting, [])
+ end
+
+end
else
subTyp (t1, t2)
+fun checkPred G (p, loc) =
+ let
+ val err = ErrorMsg.error (SOME loc)
+ in
+ case p of
+ CRoot => ()
+ | CConst s =>
+ if lookupContext G s then
+ ()
+ else
+ err ("Unbound context " ^ s)
+ | CPrefix p => checkPred G p
+ | CNot p => checkPred G p
+ | CAnd (p1, p2) => (checkPred G p1; checkPred G p2)
+ end
+
fun checkTyp G (tAll as (t, loc)) =
let
val err = ErrorMsg.error (SOME loc)
(TError, loc))
| TList t => (TList (checkTyp G t), loc)
| TArrow (d, r) => (TArrow (checkTyp G d, checkTyp G r), loc)
- | TAction (p, d, r) => (TAction (p, SM.map (checkTyp G) d,
- SM.map (checkTyp G) r), loc)
- | TNested (p, t) => (TNested (p, checkTyp G t), loc)
+ | TAction (p, d, r) => (checkPred G p;
+ (TAction (p, SM.map (checkTyp G) d,
+ SM.map (checkTyp G) r), loc))
+ | TNested (p, t) => (checkPred G p;
+ (TNested (p, checkTyp G t), loc))
| TError => raise Fail "TError in parser-generated type"
| TUnif _ => raise Fail "TUnif in parser-generated type"
end
SOME ue));
bindVal G (name, to, SOME e)
end
+ | DContext name => bindContext G name
-fun checkFile G tInit (ds, eo) =
+fun checkFile G tInit (_, ds, eo) =
let
val G' = foldl (fn (d, G) => checkDecl G d) G ds
in