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 735, Tue Nov 21 12:15:55 2000 UTC revision 736, Thu Nov 23 01:39:05 2000 UTC
# Line 158  Line 158 
158          -> expansion          -> expansion
159    
160      val defaultClassOf : (string -> bool) -> string -> class option      val defaultClassOf : (string -> bool) -> string -> class option
161    
162        val withPlugin : SrcPath.file -> (unit -> 'a) -> 'a
163  end  end
164    
165  signature TOOLS = sig  signature TOOLS = sig
# Line 230  Line 232 
232          partial_expansion          partial_expansion
233    
234      type registry = { classes : rule StringMap.map ref,      type registry = { classes : rule StringMap.map ref,
235                        sfx_classifiers : (string -> class option) list ref,                        sfx_classifiers : (string -> class option) ref,
236                        gen_classifiers : (string -> class option) list ref }                        gen_classifiers : (string -> class option) ref }
237    
238        fun layer (look1, look2) s = case look1 s of NONE => look2 s | x => x
239    
240      fun newRegistry () =  { classes = ref StringMap.empty,      fun newRegistry () =  { classes = ref StringMap.empty,
241                              sfx_classifiers = ref [],                              sfx_classifiers = ref (fn _ => NONE),
242                              gen_classifiers = ref [] } : registry                              gen_classifiers = ref (fn _ => NONE) } : registry
243    
244        (* Three registries:
245         *  1. global: where globally available tools are registered and found.
246         *  2. local: where locally available tools are found;
247         *            the local registry is being set anew every time "expand"
248         *            is being called; each instance of a local registry belongs
249         *            to one description file that is being processed.
250         *  3. plugin registries: mapping from tool implementations (indexed
251         *            by their respective description files) to that tool's
252         *            registry; here is where local tools register themselves;
253         *            the rule for the "tool" class causes the tool to register
254         *            itself if it has not already done so and then merges
255         *            the contents of the tool's registry into the current
256         *            local registry.
257         * These complications exist because tools register themselves via
258         * side-effects. *)
259    
260      val global_registry = newRegistry ()      val global_registry = newRegistry ()
261    
262      val local_registry : registry option ref = ref NONE      val local_registry : registry ref = ref (newRegistry ())
263    
264        val plugin_registries : registry SrcPathMap.map ref = ref SrcPathMap.empty
265    
266        val current_plugin : SrcPath.file option ref = ref NONE
267    
268      local      local
269          fun registry join sel () = let          fun registry sel cvt s = let
270              val get = ! o sel              val get = cvt o ! o sel
271          in          in
272              case !local_registry of              layer (get (!local_registry), get global_registry) s
                 NONE => get global_registry  
               | SOME rg => join (get rg, get global_registry)  
273          end          end
274            fun curry f x y = f (x, y)
275      in      in
276          val classes = registry (StringMap.unionWith #1) #classes          val classes = registry #classes (curry StringMap.find)
277          val sfx_classifiers = registry (op @) #sfx_classifiers          val sfx_classifiers = registry #sfx_classifiers (fn x => x)
278          val gen_classifiers = registry (op @) #gen_classifiers          val gen_classifiers = registry #gen_classifiers (fn x => x)
279      end      end
280    
281      datatype classifier =      datatype classifier =
# Line 263  Line 286 
286          SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)          SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)
287    
288      local      local
289          fun upd sel f = let          fun upd sel augment = let
290              val rf = sel (case !local_registry of              val rf =
291                                SOME rg => rg                  sel (case !current_plugin of
292                              | NONE => global_registry)                           NONE => global_registry
293                           | SOME p =>
294                             (case SrcPathMap.find (!plugin_registries, p) of
295                                  SOME r => r
296                                | NONE => let
297                                      val r = newRegistry ()
298                                  in
299                                      plugin_registries :=
300                                      SrcPathMap.insert (!plugin_registries, p, r);
301                                      r
302                                  end))
303          in          in
304              rf := f (!rf)              rf := augment (!rf)
305          end          end
306      in      in
307          fun registerClass (class, rule) =          fun registerClass (class, rule) =
308              upd #classes (fn m => StringMap.insert (m, class, rule))              upd #classes (fn m => StringMap.insert (m, class, rule))
309          fun registerClassifier (SFX_CLASSIFIER c) =          fun registerClassifier (SFX_CLASSIFIER c) =
310              upd #sfx_classifiers (fn l => c :: l)              upd #sfx_classifiers (fn c' => layer (c, c'))
311            | registerClassifier (GEN_CLASSIFIER c) =            | registerClassifier (GEN_CLASSIFIER c) =
312              upd #gen_classifiers (fn l => c :: l)              upd #gen_classifiers (fn c' => layer (c, c'))
313    
314            fun transfer_local p = let
315                val lr = !local_registry
316            in
317                case SrcPathMap.find (!plugin_registries, p) of
318                    NONE => ()
319                  | SOME pr => let
320                        fun upd sel join = sel lr := join (! (sel pr), ! (sel lr))
321                    in
322                        upd #classes (StringMap.unionWith #1);
323                        upd #sfx_classifiers layer;
324                        upd #gen_classifiers layer
325                    end
326            end
327    
328            fun withPlugin p thunk =
329                SafeIO.perform { openIt = fn () => !current_plugin before
330                                                   current_plugin := SOME p,
331                                 closeIt = fn prev => (transfer_local p;
332                                                       current_plugin := prev),
333                                 work = fn _ => thunk (),
334                                 cleanup = fn _ => () }
335      end      end
336    
337      datatype extensionStyle =      datatype extensionStyle =
# Line 333  Line 388 
388      val makeDirs = AutoDir.makeDirs      val makeDirs = AutoDir.makeDirs
389    
390      fun globally lp arg =      fun globally lp arg =
391          SafeIO.perform { openIt = fn () => !local_registry before          SafeIO.perform { openIt = fn () => !current_plugin before
392                                             local_registry := NONE,                                             current_plugin := NONE,
393                           closeIt = fn previous => local_registry := previous,                           closeIt = fn prev => current_plugin := prev,
394                           work = fn _ => lp arg,                           work = fn _ => lp arg,
395                           cleanup = fn _ => () }                           cleanup = fn _ => () }
396    
397      (* query default class *)      (* query default class *)
398      fun defaultClassOf load_plugin p = let      fun defaultClassOf load_plugin p = let
399          fun gen_loop [] = NONE          fun sfx_gen_check e =
400            | gen_loop (h :: t) =              case sfx_classifiers e of
401              (case h p of                  SOME c => SOME c
402                   NONE => gen_loop t                | NONE => gen_classifiers p
403                 | SOME c => SOME c)  
   
         fun sfx_loop e = let  
             fun loop [] = gen_loop (gen_classifiers ())  
               | loop (h :: t) =  
                 (case h e of  
                      NONE => loop t  
                    | SOME c => SOME c)  
         in  
             loop (sfx_classifiers ())  
         end  
404      in      in
405          case OS.Path.ext p of          case OS.Path.ext p of
406              SOME e =>              SOME e =>
407                  (case sfx_loop e of              (case sfx_gen_check e of
408                       SOME c => SOME c                       SOME c => SOME c
409                     | NONE => let                     | NONE => let
410                           val plugin = concat ["$/", e, "-ext.cm"]                           val plugin = concat ["$/", e, "-ext.cm"]
411                       in                       in
412                           if globally load_plugin plugin then sfx_loop e                       if globally load_plugin plugin then sfx_gen_check e
413                           else NONE                           else NONE
414                       end)                       end)
415            | NONE => gen_loop (gen_classifiers ())            | NONE => gen_classifiers p
416      end      end
417    
418      fun parseOptions { tool, keywords, options } = let      fun parseOptions { tool, keywords, options } = let
# Line 480  Line 525 
525          fun mkNativePath s =          fun mkNativePath s =
526              SrcPath.native { err = error } { context = context, spec = s }              SrcPath.native { err = error } { context = context, spec = s }
527          fun class2rule class =          fun class2rule class =
528              case StringMap.find (classes (), class) of              case classes class of
529                  SOME rule => rule                  SOME rule => rule
530                | NONE => let                | NONE => let
531                      val base = concat ["$/", class, "-tool"]                      val base = concat ["$/", class, "-tool"]
# Line 491  Line 536 
536                           smlrule)                           smlrule)
537                  in                  in
538                      if globally (load_plugin context) plugin then                      if globally (load_plugin context) plugin then
539                          case StringMap.find (classes (), class) of                          case classes class of
540                              SOME rule => rule                              SOME rule => rule
541                            | NONE => complain ()                            | NONE => complain ()
542                      else complain ()                      else complain ()
# Line 533  Line 578 
578              end              end
579      in      in
580          SafeIO.perform { openIt = fn () => !local_registry          SafeIO.perform { openIt = fn () => !local_registry
581                                             before local_registry := SOME lr,                                             before local_registry := lr,
582                           closeIt = fn previous => local_registry := previous,                           closeIt = fn prev => local_registry := prev,
583                           work = fn _ => loop ({ smlfiles = [], cmfiles = [],                           work = fn _ => loop ({ smlfiles = [], cmfiles = [],
584                                                  sources = [] },                                                  sources = [] },
585                                                [spec]),                                                [spec]),
# Line 658  Line 703 
703          fun toolrule { spec, context, mkNativePath } = let          fun toolrule { spec, context, mkNativePath } = let
704              val { name, mkpath, opts, ... } : spec = spec              val { name, mkpath, opts, ... } : spec = spec
705              fun err m = raise ToolError { tool = toolclass, msg = m }              fun err m = raise ToolError { tool = toolclass, msg = m }
706                val p = srcpath (mkpath name)
707          in          in
708              case opts of              case opts of
709                  NONE => if load_plugin' (srcpath (mkpath name)) then                  NONE => if withPlugin p (fn () => load_plugin' p) then
710                              empty_expansion                              empty_expansion
711                          else err "tool registration failed"                          else err "tool registration failed"
712                | SOME _ => err "no tool options are recognized"                | SOME _ => err "no tool options are recognized"

Legend:
Removed from v.735  
changed lines
  Added in v.736

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