Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Diff of /sml/trunk/src/cm/tools/tools.sml
ViewVC logotype

Diff of /sml/trunk/src/cm/tools/tools.sml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 271, Tue May 11 07:48:55 1999 UTC revision 272, Wed May 12 07:09:28 1999 UTC
# Line 1  Line 1 
1  signature TOOLS = sig  signature TOOLS = sig
2    
3      type primitive = Dummy.t      type fname = string
4        type class = string
5    
6        exception UnknownClass of class
7        exception ToolError of { tool: string, msg: string }
8    
9        type item = fname * class option
10    
11        (* A rule takes a file name (relative to the directory of the
12         * corresponding description file) and a rulecontext.  In general,
13         * when coding a rule one would write a rule function and pass it to
14         * the context, which will temporarily change the current working
15         * directory to the one that holds the description file ("the context").
16         * If this is not necessary for the rule to work correctly, then
17         * one can simply ignore the context (this saves system call overhead
18         * during dependency analysis). *)
19        type rulefn = unit -> item list
20        type rulecontext = rulefn -> item list
21        type rule = fname * rulecontext -> item list
22    
23        (* install a class *)
24        val registerClass : class * rule -> unit
25    
26        (* install "ML Source" class *)
27        val registerSmlClass : class * bool option -> unit
28    
29        (* install "CM Group" class *)
30        val registerGroupClass : class -> unit
31    
32        (* classifiers are used when the class is not given explicitly *)
33        datatype classifier =
34            SFX_CLASSIFIER of string -> class option
35          | GEN_CLASSIFIER of string -> class option
36    
37        (* make a classifier which looks for a specific file name suffix *)
38        val stdSfxClassifier : { sfx: string, class: class } -> classifier
39    
40        (* install a classifier *)
41        val registerClassifier : classifier -> unit
42    
43        (* query default class *)
44        val defaultClassOf : fname -> class option
45    end
46    
47    signature PRIVATETOOLS = sig
48    
49        include TOOLS
50    
51        type primitive = Primitive.primitive
52    
53      type smlsource =      type smlsource =
54          { sourcepath: AbsPath.t, history: string, share: bool option }          { sourcepath: AbsPath.t, history: class list, share: bool option }
55    
56      datatype expansion =      datatype expansion =
57          PRIMITIVE of primitive          PRIMITIVE of primitive
58        | SMLSOURCE of smlsource        | SMLSOURCE of smlsource
59        | GROUP of AbsPath.t        | GROUP of AbsPath.t
60    
61      val expand : AbsPath.t * string option -> expansion list      datatype private_rule =
62            ISPRIMITIVE
63          | ISSML of bool option
64          | ISGROUP
65          | ISTOOL of class * rule
66    
67        val registerPrimitiveClass : class -> unit
68    
69        val expand : AbsPath.t * class option -> expansion list
70  end  end
71    
72  structure Tools :> TOOLS = struct  structure PrivateTools :> PRIVATETOOLS = struct
73    
74        type fname = string
75        type class = string
76    
77        exception UnknownClass of class
78        exception ToolError of { tool: string, msg: string }
79    
80        type item = fname * class option
81    
82        type rulefn = unit -> item list
83        type rulecontext = rulefn -> item list
84        type rule = fname * rulecontext -> item list
85    
86      type primitive = Dummy.t      type primitive = Primitive.primitive
87    
88      type smlsource =      type smlsource =
89          { sourcepath: AbsPath.t, history: string, share: bool option }          { sourcepath: AbsPath.t, history: class list, share: bool option }
90    
91      datatype expansion =      datatype expansion =
92          PRIMITIVE of primitive          PRIMITIVE of primitive
93        | SMLSOURCE of smlsource        | SMLSOURCE of smlsource
94        | GROUP of AbsPath.t        | GROUP of AbsPath.t
95    
96      fun expand (p, c) = Dummy.f ()      datatype private_rule =
97            ISPRIMITIVE
98          | ISSML of bool option
99          | ISGROUP
100          | ISTOOL of class * rule
101    
102        val classes : private_rule StringMap.map ref = ref (StringMap.empty)
103    
104        fun registerClass (class, rule) =
105            classes := StringMap.insert (!classes, class, ISTOOL (class, rule))
106    
107        fun registerSmlClass (class, share) =
108            classes := StringMap.insert (!classes, class, ISSML share)
109    
110        fun registerGroupClass class =
111            classes := StringMap.insert (!classes, class, ISGROUP)
112    
113        fun registerPrimitiveClass class =
114            classes := StringMap.insert (!classes, class, ISPRIMITIVE)
115    
116        (* classifiers are used when the class is not given explicitly *)
117        datatype classifier =
118            SFX_CLASSIFIER of string -> class option
119          | GEN_CLASSIFIER of string -> class option
120    
121        (* make a classifier which looks for a specific file name suffix *)
122        fun stdSfxClassifier { sfx, class } =
123            SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)
124    
125        (* install a classifier *)
126        val sfx_classifiers: (string -> class option) list ref = ref []
127        val gen_classifiers: (fname -> class option) list ref = ref []
128    
129        local
130            fun add (x, r) = r := x :: (!r)
131        in
132            fun registerClassifier (SFX_CLASSIFIER c) = add (c, sfx_classifiers)
133              | registerClassifier (GEN_CLASSIFIER c) = add (c, gen_classifiers)
134  end  end
135    
136        (* query default class *)
137        fun defaultClassOf p = let
138            fun gen_loop [] = NONE
139              | gen_loop (h :: t) =
140                (case h p of
141                     NONE => gen_loop t
142                   | SOME c => SOME c)
143    
144            fun sfx_loop e = let
145                fun loop [] = gen_loop (!gen_classifiers)
146                  | loop (h :: t) =
147                    (case h e of
148                         NONE => loop t
149                       | SOME c => SOME c)
150            in
151                loop (!sfx_classifiers)
152            end
153        in
154            case OS.Path.ext p of
155                SOME e => sfx_loop e
156              | NONE => gen_loop (!gen_classifiers)
157        end
158    
159        (* get the rule corresponding to a given class *)
160        fun class2rule class =
161            case StringMap.find (!classes, class) of
162                SOME rule => rule
163              | NONE => raise UnknownClass class
164    
165        (* apply a rule to a path within a given context *)
166        fun apply (rule, p, c) = let
167            fun rctxt rf = let
168                val dir = AbsPath.contextName c
169                val cwd = OS.FileSys.getDir ()
170                fun doit () =
171                    (OS.FileSys.chDir dir; rf () before OS.FileSys.chDir cwd)
172            in
173                (Interrupt.guarded doit)
174                handle exn => (OS.FileSys.chDir cwd; raise exn)
175            end
176        in
177            rule (p, rctxt)
178        end
179    
180        fun expand' context = let
181            fun loop (acc, []) = rev acc
182              | loop (acc, ((p, c), history) :: t) = let
183                    fun step ISPRIMITIVE =
184                        loop (PRIMITIVE (Primitive.fromString p) :: acc, t)
185                      | step (ISSML share) = let
186                            val ap = AbsPath.native { context = context, spec = p }
187                            val src = { sourcepath = ap,
188                                        history = rev history,
189                                        share = share }
190                        in
191                            loop (SMLSOURCE src :: acc, t)
192                        end
193                      | step ISGROUP = let
194                            val ap = AbsPath.native { context = context, spec = p }
195                        in
196                            loop (GROUP ap :: acc, t)
197                        end
198                      | step (ISTOOL (class, rule)) = let
199                            val l = apply (rule, p, context)
200                            val l' = map (fn i => (i, class :: history)) l
201                        in
202                            loop (acc, l' @ t)
203                        end
204                in
205                    case c of
206                        SOME class => step (class2rule class)
207                      | NONE => step (ISSML NONE)
208                end
209        in
210            fn l => loop ([], l)
211        end
212    
213        fun expand (ap, SOME class) =
214            (case class2rule class of
215                 ISPRIMITIVE =>
216                     [PRIMITIVE (Primitive.fromString (AbsPath.spec ap))]
217               | ISSML share =>
218                     [SMLSOURCE { sourcepath = ap, history = [], share = share }]
219               | ISGROUP =>
220                     [GROUP ap]
221               | ISTOOL (class, rule) => let
222                     val c = AbsPath.context ap
223                     val l = apply (rule, AbsPath.spec ap, c)
224                     val l' = map (fn i => (i, [class])) l
225                 in
226                     expand' (AbsPath.context ap) l'
227                 end)
228          | expand (ap, NONE) =
229                 expand' (AbsPath.context ap) [((AbsPath.spec ap, NONE), [])]
230    end
231    
232    structure Tools :> TOOLS = PrivateTools

Legend:
Removed from v.271  
changed lines
  Added in v.272

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0