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 734, Sun Nov 19 05:27:41 2000 UTC revision 735, Tue Nov 21 12:15:55 2000 UTC
# Line 146  Line 146 
146      include CORETOOLS where type srcpath = SrcPath.file      include CORETOOLS where type srcpath = SrcPath.file
147                        where type presrcpath = SrcPath.prefile                        where type presrcpath = SrcPath.prefile
148    
149        type registry
150    
151        val newRegistry : unit -> registry
152    
153      val expand : { error: string -> unit,      val expand : { error: string -> unit,
154                       local_registry : registry,
155                     spec: spec,                     spec: spec,
156                     context: SrcPath.dir,                     context: SrcPath.dir,
157                     load_plugin: SrcPath.dir -> string -> bool }                     load_plugin: SrcPath.dir -> string -> bool }
# Line 224  Line 229 
229          { spec: spec, mkNativePath: pathmaker, context: rulecontext } ->          { spec: spec, mkNativePath: pathmaker, context: rulecontext } ->
230          partial_expansion          partial_expansion
231    
232      val classes : rule StringMap.map ref = ref StringMap.empty      type registry = { classes : rule StringMap.map ref,
233                          sfx_classifiers : (string -> class option) list ref,
234                          gen_classifiers : (string -> class option) list ref }
235    
236      fun registerClass (class, rule) =      fun newRegistry () =  { classes = ref StringMap.empty,
237          classes := StringMap.insert (!classes, class, rule)                              sfx_classifiers = ref [],
238                                gen_classifiers = ref [] } : registry
239    
240        val global_registry = newRegistry ()
241    
242        val local_registry : registry option ref = ref NONE
243    
244        local
245            fun registry join sel () = let
246                val get = ! o sel
247            in
248                case !local_registry of
249                    NONE => get global_registry
250                  | SOME rg => join (get rg, get global_registry)
251            end
252        in
253            val classes = registry (StringMap.unionWith #1) #classes
254            val sfx_classifiers = registry (op @) #sfx_classifiers
255            val gen_classifiers = registry (op @) #gen_classifiers
256        end
257    
258      datatype classifier =      datatype classifier =
259          SFX_CLASSIFIER of string -> class option          SFX_CLASSIFIER of string -> class option
# Line 236  Line 262 
262      fun stdSfxClassifier { sfx, class } =      fun stdSfxClassifier { sfx, class } =
263          SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)          SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)
264    
265        local
266            fun upd sel f = let
267                val rf = sel (case !local_registry of
268                                  SOME rg => rg
269                                | NONE => global_registry)
270            in
271                rf := f (!rf)
272            end
273        in
274            fun registerClass (class, rule) =
275                upd #classes (fn m => StringMap.insert (m, class, rule))
276            fun registerClassifier (SFX_CLASSIFIER c) =
277                upd #sfx_classifiers (fn l => c :: l)
278              | registerClassifier (GEN_CLASSIFIER c) =
279                upd #gen_classifiers (fn l => c :: l)
280        end
281    
282      datatype extensionStyle =      datatype extensionStyle =
283          EXTEND of (string * class option * tooloptcvt) list          EXTEND of (string * class option * tooloptcvt) list
284        | REPLACE of string list * (string * class option * tooloptcvt) list        | REPLACE of string list * (string * class option * tooloptcvt) list
# Line 289  Line 332 
332      val openTextOut = AutoDir.openTextOut      val openTextOut = AutoDir.openTextOut
333      val makeDirs = AutoDir.makeDirs      val makeDirs = AutoDir.makeDirs
334    
335      val sfx_classifiers : (string -> class option) list ref = ref []      fun globally lp arg =
336      val gen_classifiers : (string -> class option) list ref = ref []          SafeIO.perform { openIt = fn () => !local_registry before
337                                               local_registry := NONE,
338      local                           closeIt = fn previous => local_registry := previous,
339          fun add (x, r) = r := x :: (!r)                           work = fn _ => lp arg,
340      in                           cleanup = fn _ => () }
         fun registerClassifier (SFX_CLASSIFIER c) = add (c, sfx_classifiers)  
           | registerClassifier (GEN_CLASSIFIER c) = add (c, gen_classifiers)  
     end  
341    
342      (* query default class *)      (* query default class *)
343      fun defaultClassOf load_plugin p = let      fun defaultClassOf load_plugin p = let
# Line 308  Line 348 
348                 | SOME c => SOME c)                 | SOME c => SOME c)
349    
350          fun sfx_loop e = let          fun sfx_loop e = let
351              fun loop [] = gen_loop (!gen_classifiers)              fun loop [] = gen_loop (gen_classifiers ())
352                | loop (h :: t) =                | loop (h :: t) =
353                  (case h e of                  (case h e of
354                       NONE => loop t                       NONE => loop t
355                     | SOME c => SOME c)                     | SOME c => SOME c)
356          in          in
357              loop (!sfx_classifiers)              loop (sfx_classifiers ())
358          end          end
359      in      in
360          case OS.Path.ext p of          case OS.Path.ext p of
# Line 322  Line 362 
362                  (case sfx_loop e of                  (case sfx_loop e of
363                       SOME c => SOME c                       SOME c => SOME c
364                     | NONE => let                     | NONE => let
365                           fun try pre = let                           val plugin = concat ["$/", e, "-ext.cm"]
                              val plugin = concat [pre, e, "-ext.cm"]  
366                           in                           in
367                               load_plugin plugin                           if globally load_plugin plugin then sfx_loop e
                          end  
                      in  
                          if try "$/" orelse try "./" then sfx_loop e  
368                           else NONE                           else NONE
369                       end)                       end)
370            | NONE => gen_loop (!gen_classifiers)            | NONE => gen_loop (gen_classifiers ())
371      end      end
372    
373      fun parseOptions { tool, keywords, options } = let      fun parseOptions { tool, keywords, options } = let
# Line 440  Line 476 
476           [])           [])
477      end      end
478    
479      fun expand { error, spec, context, load_plugin } = let      fun expand { error, local_registry = lr, spec, context, load_plugin } = let
480          fun mkNativePath s =          fun mkNativePath s =
481              SrcPath.native { err = error } { context = context, spec = s }              SrcPath.native { err = error } { context = context, spec = s }
482          fun class2rule class =          fun class2rule class =
483              case StringMap.find (!classes, class) of              case StringMap.find (classes (), class) of
484                  SOME rule => rule                  SOME rule => rule
485                | NONE => let                | NONE => let
486                      val base = concat ["$", class, "-tool"]                      val base = concat ["$/", class, "-tool"]
487                      val plugin = OS.Path.joinBaseExt { base = base,                      val plugin = OS.Path.joinBaseExt { base = base,
488                                                         ext = SOME "cm" }                                                         ext = SOME "cm" }
489                      fun complain () =                      fun complain () =
490                          (error (concat ["unknown class \"", class, "\""]);                          (error (concat ["unknown class \"", class, "\""]);
491                           smlrule)                           smlrule)
492                  in                  in
493                      if load_plugin context plugin then                      if globally (load_plugin context) plugin then
494                          case StringMap.find (!classes, class) of                          case StringMap.find (classes (), class) of
495                              SOME rule => rule                              SOME rule => rule
496                            | NONE => complain ()                            | NONE => complain ()
497                      else complain ()                      else complain ()
# Line 496  Line 532 
532                        il @ items)                        il @ items)
533              end              end
534      in      in
535          loop ({ smlfiles = [], cmfiles = [], sources = [] }, [spec])          SafeIO.perform { openIt = fn () => !local_registry
536                                               before local_registry := SOME lr,
537                             closeIt = fn previous => local_registry := previous,
538                             work = fn _ => loop ({ smlfiles = [], cmfiles = [],
539                                                    sources = [] },
540                                                  [spec]),
541                             cleanup = fn _ => () }
542      end      end
543    
544      local      local
# Line 514  Line 556 
556  end  end
557    
558  functor ToolsFn (val load_plugin : string -> bool  functor ToolsFn (val load_plugin : string -> bool
559                     val load_plugin' : SrcPath.file -> bool
560                   val penv: SrcPath.env) : TOOLS = struct                   val penv: SrcPath.env) : TOOLS = struct
561    
562      open PrivateTools      open PrivateTools
# Line 523  Line 566 
566      val vsay = Say.vsay      val vsay = Say.vsay
567    
568      fun mkCmdName cmdStdPath =      fun mkCmdName cmdStdPath =
569          (* It is not enough to turn the string into a SrcPath.file          (* The result of this function should not be cached. Otherwise
570           * once.  This is because if there was no anchor in the           * a later addition or change of an anchor will go unnoticed. *)
          * beginning, later additions of an anchor will go unnoticed.  
          * This is different from how other files (ML source files etc.)  
          * behave: They, once the are found to be unanchored, should  
          * never become (implicitly) anchored later (although an existing  
          * anchor is allowed to change). Of course, the whole issue  
          * becomes moot once there are no more implicitly anchored paths. *)  
571          case SrcPath.get_anchor (penv, cmdStdPath) of          case SrcPath.get_anchor (penv, cmdStdPath) of
572              NONE => cmdStdPath              NONE => cmdStdPath
573            | SOME p => OS.Path.joinDirFile { dir = p, file = cmdStdPath }            | SOME p => OS.Path.joinDirFile { dir = p, file = cmdStdPath }
# Line 612  Line 649 
649          registerClass (class, rule);          registerClass (class, rule);
650          app sfx suffixes          app sfx suffixes
651      end      end
652    
653        local
654            val toolclass = "tool"
655            val suffixclass = "suffix"
656            val empty_expansion =
657                ({ cmfiles = [], smlfiles = [], sources = [] }, [])
658            fun toolrule { spec, context, mkNativePath } = let
659                val { name, mkpath, opts, ... } : spec = spec
660                fun err m = raise ToolError { tool = toolclass, msg = m }
661            in
662                case opts of
663                    NONE => if load_plugin' (srcpath (mkpath name)) then
664                                empty_expansion
665                            else err "tool registration failed"
666                  | SOME _ => err "no tool options are recognized"
667            end
668            fun suffixrule { spec, context, mkNativePath } = let
669                val { name = s, opts, ... } : spec = spec
670                fun err m = raise ToolError { tool = suffixclass, msg = m }
671                fun reg c =
672                    (registerClassifier (stdSfxClassifier { sfx = s, class = c });
673                     empty_expansion)
674            in
675                case opts of
676                    SOME [STRING c] => reg (#name c)
677                  | SOME [SUBOPTS { name = "class", opts = [STRING c] }] =>
678                    reg (#name c)
679                  | _ => err "invalid options"
680            end
681        in
682            val _ = registerClass (toolclass, toolrule)
683            val _ = registerClass (suffixclass, suffixrule)
684        end
685  end  end

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

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