From 095de39e1be653dcb6438d19c719bd7797e0772a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 30 Jul 2006 19:06:07 +0000 Subject: [PATCH] Dependency ordering --- configDefault/domtool.cfg | 3 +- configDefault/domtool.cfs | 4 + lib/alias.dtl | 47 +++++++ lib/base.dtl | 2 + lib/domain.dtl | 10 ++ src/ast.sml | 3 +- src/domain.sml | 4 +- src/domtool.cm | 3 + src/domtool.grm | 9 +- src/domtool.lex | 1 + src/env.sig | 5 + src/env.sml | 21 +-- src/main.sml | 4 +- src/order.sig | 25 ++++ src/order.sml | 277 ++++++++++++++++++++++++++++++++++++++ src/tycheck.sml | 27 +++- 16 files changed, 423 insertions(+), 22 deletions(-) create mode 100644 lib/alias.dtl create mode 100644 lib/base.dtl create mode 100644 lib/domain.dtl create mode 100644 src/order.sig create mode 100644 src/order.sml diff --git a/configDefault/domtool.cfg b/configDefault/domtool.cfg index 4fdde33..1f9f8fe 100644 --- a/configDefault/domtool.cfg +++ b/configDefault/domtool.cfg @@ -1 +1,2 @@ -val configRoot = "/home/adamc/domtool" +val configRoot = "/home/adamc/cvs/domtool2/lib" +val resultRoot = "/home/adamc/domtool" diff --git a/configDefault/domtool.cfs b/configDefault/domtool.cfs index 7d9aecc..7d24e60 100644 --- a/configDefault/domtool.cfs +++ b/configDefault/domtool.cfs @@ -1,3 +1,7 @@ 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. *) diff --git a/lib/alias.dtl b/lib/alias.dtl new file mode 100644 index 0000000..0ced362 --- /dev/null +++ b/lib/alias.dtl @@ -0,0 +1,47 @@ +{{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.}} diff --git a/lib/base.dtl b/lib/base.dtl new file mode 100644 index 0000000..3e8989b --- /dev/null +++ b/lib/base.dtl @@ -0,0 +1,2 @@ +extern type int; +extern type string; diff --git a/lib/domain.dtl b/lib/domain.dtl new file mode 100644 index 0000000..8bf46fd --- /dev/null +++ b/lib/domain.dtl @@ -0,0 +1,10 @@ +{{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.}} diff --git a/src/ast.sml b/src/ast.sml index efc2fb0..29d7cb2 100644 --- a/src/ast.sml +++ b/src/ast.sml @@ -95,8 +95,9 @@ datatype decl' = 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 diff --git a/src/domain.sml b/src/domain.sml index 99152ea..4ec6f55 100644 --- a/src/domain.sml +++ b/src/domain.sml @@ -71,7 +71,7 @@ fun getPath domain = 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 @@ -83,7 +83,7 @@ fun getPath domain = elems end) [] toks in - String.concatWith "/" (Config.configRoot :: rev ("" :: elems)) + String.concatWith "/" (Config.resultRoot :: rev ("" :: elems)) end val _ = Env.container_one "domain" diff --git a/src/domtool.cm b/src/domtool.cm index 33722c5..c3b66d7 100644 --- a/src/domtool.cm +++ b/src/domtool.cm @@ -47,5 +47,8 @@ domain.sml alias.sig alias.sml +order.sig +order.sml + main.sig main.sml diff --git a/src/domtool.grm b/src/domtool.grm index 17ad3c1..e7ce9ea 100644 --- a/src/domtool.grm +++ b/src/domtool.grm @@ -33,7 +33,7 @@ open Ast | 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 @@ -76,17 +76,18 @@ open Ast %% -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) diff --git a/src/domtool.lex b/src/domtool.lex index 5e40aa2..cafd14e 100644 --- a/src/domtool.lex +++ b/src/domtool.lex @@ -131,6 +131,7 @@ lineComment = #[^\n]*\n; "extern" => (Tokens.EXTERN (yypos, yypos + size yytext)); "type" => (Tokens.TYPE (yypos, yypos + size yytext)); "val" => (Tokens.VAL (yypos, yypos + size yytext)); + "context" => (Tokens.CONTEXT (yypos, yypos + size yytext)); "Root" => (Tokens.ROOT (yypos, yypos + size yytext)); diff --git a/src/env.sig b/src/env.sig index adbf0b4..5108bea 100644 --- a/src/env.sig +++ b/src/env.sig @@ -56,9 +56,14 @@ signature ENV = sig 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 diff --git a/src/env.sml b/src/env.sml index acc7e36..48ec715 100644 --- a/src/env.sml +++ b/src/env.sml @@ -96,21 +96,26 @@ fun action_two name args f = registerAction (name, two name args f) 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 diff --git a/src/main.sml b/src/main.sml index bbf1091..e00562a 100644 --- a/src/main.sml +++ b/src/main.sml @@ -57,7 +57,7 @@ fun reduce fname = () else case prog of - (_, SOME body) => + (_, _, SOME body) => let val body' = Reduce.reduceExp G' body in @@ -84,7 +84,7 @@ fun eval fname = () else case prog of - (_, SOME body) => + (_, _, SOME body) => let val body' = Reduce.reduceExp G' body in diff --git a/src/order.sig b/src/order.sig new file mode 100644 index 0000000..10621dd --- /dev/null +++ b/src/order.sig @@ -0,0 +1,25 @@ +(* 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 diff --git a/src/order.sml b/src/order.sml new file mode 100644 index 0000000..47ee1bc --- /dev/null +++ b/src/order.sml @@ -0,0 +1,277 @@ +(* 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 diff --git a/src/tycheck.sml b/src/tycheck.sml index ac69a6d..ac9fad5 100644 --- a/src/tycheck.sml +++ b/src/tycheck.sml @@ -296,6 +296,22 @@ fun hasTyp (e, t1, t2) = 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) @@ -309,9 +325,11 @@ fun checkTyp G (tAll as (t, 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 @@ -662,8 +680,9 @@ fun checkDecl G (d, _, loc) = 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 -- 2.20.1