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 517, Wed Jan 12 03:17:34 2000 UTC revision 518, Wed Jan 12 06:26:25 2000 UTC
# Line 5  Line 5 
5   *   *
6   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)   * Author: Matthias Blume (blume@kurims.kyoto-u.ac.jp)
7   *)   *)
8  signature TOOLS = sig  signature CORETOOLS = sig
9    
10      (* We don't make classes abstract.  It doesn't look like there      (* We don't make classes abstract.  It doesn't look like there
11       * would be much point to it. *)       * would be much point to it. *)
# Line 43  Line 43 
43       * expanded... *)       * expanded... *)
44      type partial_expansion = expansion * spec list      type partial_expansion = expansion * spec list
45    
46      (* A rule takes a spec and a rulecontext where the name name contained      (* A rule takes a spec and a rulecontext where the name contained
47       * in the spec -- if relative -- is considered relative to the directory       * in the spec -- if relative -- is considered relative to the directory
48       * of the corresponding description file.  In general,       * of the corresponding description file.  In general,
49       * when coding a rule one would write a rule function and pass it to       * when coding a rule one would write a rule function and pass it to
# Line 77  Line 77 
77    
78      (* two standard ways of dealing with filename extensions... *)      (* two standard ways of dealing with filename extensions... *)
79      datatype extensionStyle =      datatype extensionStyle =
80          EXTEND of string list          EXTEND of (string * class option) list
81        | REPLACE of string list * string list        | REPLACE of string list * (string * class option) list
82    
83      type cmdController = { get: unit -> string, set: string -> unit }      type cmdController = { get: unit -> string, set: string -> unit }
84    
# Line 88  Line 88 
88                                      class: string,                                      class: string,
89                                      suffixes: string list,                                      suffixes: string list,
90                                      command: cmdController,                                      command: cmdController,
91                                      extensionStyle: extensionStyle,                                      extensionStyle: extensionStyle } -> unit
                                     sml: bool } -> unit  
92    
93      (* perform filename extension *)      (* perform filename extension *)
94      val extend : extensionStyle -> string -> string list      val extend : extensionStyle -> string -> (string * class option) list
95    
96      (* check for outdated files; the pathname strings must be in      (* check for outdated files; the pathname strings must be in
97       * native syntax! *)       * native syntax! *)
# Line 100  Line 99 
99    
100      (* install a classifier *)      (* install a classifier *)
101      val registerClassifier : classifier -> unit      val registerClassifier : classifier -> unit
   
     (* query default class *)  
     val defaultClassOf : string -> class option  
102  end  end
103    
104  signature PRIVATETOOLS = sig  signature PRIVATETOOLS = sig
105      include TOOLS where type srcpath = SrcPath.t      include CORETOOLS where type srcpath = SrcPath.t
106    
107      val expand : { error: string -> unit,      val expand : { error: string -> unit,
108                     spec: spec,                     spec: spec,
109                     context: SrcPath.context }                     context: SrcPath.context,
110                       load_plugin: string -> bool }
111          -> expansion          -> expansion
112    
113        val defaultClassOf : (string -> bool) -> string -> class option
114    end
115    
116    signature TOOLS = sig
117        include CORETOOLS
118    
119        (* query default class *)
120        val defaultClassOf : string -> class option
121  end  end
122    
123  structure PrivateTools :> PRIVATETOOLS = struct  structure PrivateTools :> PRIVATETOOLS = struct
# Line 151  Line 158 
158          SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)          SFX_CLASSIFIER (fn e => if sfx = e then SOME class else NONE)
159    
160      datatype extensionStyle =      datatype extensionStyle =
161          EXTEND of string list          EXTEND of (string * class option) list
162        | REPLACE of string list * string list        | REPLACE of string list * (string * class option) list
163    
164      type cmdController = { get: unit -> string, set: string -> unit }      type cmdController = { get: unit -> string, set: string -> unit }
165    
166      fun newCmdController sp = EnvConfig.new SOME sp      fun newCmdController sp = EnvConfig.new SOME sp
167    
168      fun extend (EXTEND l) f = map (fn s => concat [f, ".", s]) l      fun extend (EXTEND l) f = map (fn (s, co) => (concat [f, ".", s], co)) l
169        | extend (REPLACE (ol, nl)) f = let        | extend (REPLACE (ol, nl)) f = let
170              val { base, ext } = OS.Path.splitBaseExt f              val { base, ext } = OS.Path.splitBaseExt f
171              fun join b e = OS.Path.joinBaseExt { base = b, ext = SOME e }              fun join b (e, co) =
172                    (OS.Path.joinBaseExt { base = b, ext = SOME e }, co)
173              fun gen b = map (join b) nl              fun gen b = map (join b) nl
174              fun sameExt (e1: string) (e2: string) = e1 = e2              fun sameExt (e1: string) (e2: string) = e1 = e2
175          in          in
# Line 194  Line 202 
202      end      end
203    
204      fun registerStdShellCmdTool args = let      fun registerStdShellCmdTool args = let
205          val { tool, class, suffixes, command, extensionStyle, sml } = args          val { tool, class, suffixes, command, extensionStyle } = args
206          fun rule { spec = (name, mkpath, _), context, mkNativePath } = let          fun rule { spec = (name, mkpath, _), context, mkNativePath } = let
207              val nativename = nativeSpec (mkpath name)              val nativename = nativeSpec (mkpath name)
208              val targetfiles = extend extensionStyle nativename              val targetfiles = extend extensionStyle nativename
209              val partial_expansion =              val partial_expansion =
210                  if sml then                  ({ smlfiles = [], cmfiles = [] },
211                      ({ smlfiles =                   map (fn (f, co) => (f, mkNativePath, co)) targetfiles)
                         map (fn f => (mkNativePath f, Sharing.DONTCARE))  
                             targetfiles,  
                        cmfiles = [] },  
                      [])  
                 else ({ smlfiles = [], cmfiles = [] },  
                       map (fn f => (f, mkNativePath, NONE)) targetfiles)  
212              fun runcmd () = let              fun runcmd () = let
213                  val cmd =                  val cmd =
214                      concat [#get (command: cmdController) (), " ", nativename]                      concat [#get (command: cmdController) (), " ", nativename]
# Line 216  Line 218 
218                  else raise ToolError { tool = tool, msg = cmd }                  else raise ToolError { tool = tool, msg = cmd }
219              end              end
220              fun rulefn () =              fun rulefn () =
221                  (if outdated tool (targetfiles, nativename) then runcmd ()                  (if outdated tool (map #1 targetfiles, nativename) then
222                         runcmd ()
223                   else ();                   else ();
224                   partial_expansion)                   partial_expansion)
225          in          in
# Line 230  Line 233 
233      end      end
234    
235      (* query default class *)      (* query default class *)
236      fun defaultClassOf p = let      fun defaultClassOf load_plugin p = let
237          fun gen_loop [] = NONE          fun gen_loop [] = NONE
238            | gen_loop (h :: t) =            | gen_loop (h :: t) =
239              (case h p of              (case h p of
# Line 248  Line 251 
251          end          end
252      in      in
253          case OS.Path.ext p of          case OS.Path.ext p of
254              SOME e => sfx_loop e              SOME e =>
255                    (case sfx_loop e of
256                         SOME c => SOME c
257                       | NONE => let
258                             val plugin = OS.Path.joinBaseExt { base = e ^ "-ext",
259                                                                ext = SOME "cm" }
260                         in
261                             if load_plugin plugin then sfx_loop e else NONE
262                         end)
263            | NONE => gen_loop (!gen_classifiers)            | NONE => gen_loop (!gen_classifiers)
264      end      end
265    
# Line 257  Line 268 
268      fun cmrule { spec = (name, mkpath, _), context, mkNativePath } =      fun cmrule { spec = (name, mkpath, _), context, mkNativePath } =
269          ({ smlfiles = [], cmfiles = [mkpath name] }, [])          ({ smlfiles = [], cmfiles = [mkpath name] }, [])
270    
271      fun expand { error, spec, context } = let      fun expand { error, spec, context, load_plugin } = let
272          fun mkNativePath s = SrcPath.native { context = context, spec = s }          fun mkNativePath s = SrcPath.native { context = context, spec = s }
273          fun class2rule class =          fun class2rule class =
274              case StringMap.find (!classes, class) of              case StringMap.find (!classes, class) of
275                  SOME rule => rule                  SOME rule => rule
276                | NONE => (error (concat ["unknown class \"", class, "\""]);                | NONE => let
277                        val plugin = OS.Path.joinBaseExt { base = class ^ "-tool",
278                                                           ext = SOME "cm" }
279                        fun complain () =
280                            (error (concat ["unknown class \"", class, "\""]);
281                           smlrule Sharing.DONTCARE)                           smlrule Sharing.DONTCARE)
282                    in
283                        if load_plugin plugin then
284                            case StringMap.find (!classes, class) of
285                                SOME rule => rule
286                              | NONE => complain ()
287                        else complain ()
288                    end
289    
290          fun expand1 (spec as (name, _, co)) = let          fun expand1 (spec as (name, _, co)) = let
291              val rule =              val rule =
292                  case co of                  case co of
293                      SOME c0 => class2rule (String.map Char.toLower c0)                      SOME c0 => class2rule (String.map Char.toLower c0)
294                    | NONE =>                    | NONE =>
295                          (case defaultClassOf name of                          (case defaultClassOf load_plugin name of
296                               SOME c => class2rule c                               SOME c => class2rule c
297                             | NONE => smlrule Sharing.DONTCARE)                             | NONE => smlrule Sharing.DONTCARE)
298              fun rcontext rf = let              fun rcontext rf = let
# Line 314  Line 337 
337      end      end
338  end  end
339    
340  structure Tools : TOOLS = PrivateTools  functor ToolsFn (val load_plugin : string -> bool) : TOOLS = struct
341        open PrivateTools
342        val defaultClassOf = defaultClassOf load_plugin
343    end

Legend:
Removed from v.517  
changed lines
  Added in v.518

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