Module:    environment-commands
Synopsis:  The commands provided by the environment
Author:	   Andy Armstrong
Copyright:    Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
              All rights reserved.
License:      Functional Objects Library Public License Version 1.0
Dual-license: GNU Lesser General Public License
Warranty:     Distributed WITHOUT WARRANTY OF ANY KIND

/// Build properties

// Compilation mode

define class <compiler-back-end-property> (<environment-property>)
end class <compiler-back-end-property>;

define command-property compiler-back-end => <compiler-back-end-property>
  (summary:       "current compiler back end",
   documentation: "The current back-end code generator.",
   type:          <symbol>,
   persistent?:   #t)
end command-property compiler-back-end;

define method show-property
  (context :: <environment-context>, property :: <compiler-back-end-property>)
 => ()
  let back-end = session-property(#"compiler-back-end");
  message(context, "Compiler back end: %s", back-end);
end method show-property;

define method set-property
  (context :: <environment-context>, property :: <compiler-back-end-property>,
   back-end :: <symbol>,
   #key save?)
 => ()
  ignore(save?);
  session-property(#"compiler-back-end") :=
    select (back-end)
      #"harp", #"c" => back-end;
      otherwise => set-error("Unrecognized back end: %s", back-end);
    end;
end method set-property;

define class <compilation-mode-property> (<project-property>)
end class <compilation-mode-property>;

define command-property compilation-mode => <compilation-mode-property>
  (summary:       "compilation mode",
   documentation: "The project's compilation mode.",
   type:          <symbol>,
   persistent?:   #t)
end command-property compilation-mode;

define method show-property
    (context :: <environment-context>, property :: <compilation-mode-property>)
 => ()
  let project = context.context-project;
  message(context, "Compilation mode: %s",
	  select (project.project-compilation-mode)
	    #"loose"  => "development [Interactive development mode]";
	    #"tight"  => "production  [Production mode]";
	  end)
end method show-property;

define method set-property
    (context :: <environment-context>, property :: <compilation-mode-property>,
     compilation-mode :: <symbol>,
     #key save?)
 => ()
  //--- Need to do a non-persistent version!
  ignore(save?);
  let project = context.context-project;
  let compilation-mode
    = select (compilation-mode)
	#"tight", #"production"  => #"tight";
	#"loose", #"development" => #"loose";
	otherwise =>
	  set-error("Unrecognised compilation mode: %s", compilation-mode);
      end;
  project.project-compilation-mode := compilation-mode
end method set-property;


// Build script

define class <build-script-property> (<environment-property>)
end class <build-script-property>;

define command-property build-script => <build-script-property>
  (summary:       "current build script",
   documentation: "The currently active build script.",
   type:          <file-locator>,
   persistent?:   #t)
end command-property build-script;

define method show-property
    (context :: <environment-context>, property :: <build-script-property>)
 => ()
  let project-context = context.context-project-context;
  let build-script
    = if (project-context)
	project-context.context-build-script
      else
	default-build-script()
      end;
  message(context, "Build script: %s", build-script);
end method show-property;

define method set-property
    (context :: <environment-context>, property :: <build-script-property>, 
     build-script :: <file-locator>,
     #key save?)
 => ()
  let project-context = context.context-project-context;
  if (project-context)
    project-context.context-build-script := build-script;
  end;
  if (save?)
    default-build-script() := build-script;
  end
end method set-property;


/// Build command

define class <abstract-link-command> (<project-command>)
  constant slot %project :: false-or(<project-object>) = #f,
    init-keyword: project:;
  constant slot %build-script :: false-or(<file-locator>) = #f,
    init-keyword: build-script:;
  constant slot %target :: false-or(<symbol>) = #f,
    init-keyword: target:;
  constant slot %force? :: <boolean> = #f,
    init-keyword: force?:;
  constant slot %subprojects? :: <boolean> = #t,
    init-keyword: subprojects?:;
  constant slot %unify? :: <boolean> = #f,
    init-keyword: unify?:;
end class <abstract-link-command>;

define class <build-project-command> (<abstract-link-command>)
  constant slot %clean? :: <boolean> = #f,
    init-keyword: clean?:;
  constant slot %save? :: <boolean> = #t,
    init-keyword: save?:;
  constant slot %link? :: <boolean> = #t,
    init-keyword: link?:;
  constant slot %output :: <sequence> = #[],
    init-keyword: output:;
  constant slot %release? :: <boolean> = #f,
    init-keyword: release?:;
end class <build-project-command>;

define command-line build => <build-project-command>
    (summary:       "builds a project's executable",
     documentation: "Builds the executable for a project.")
  optional project :: <project-object> = "the project to build";
  keyword output :: $keyword-list-type = "debug output types [default none]";
  flag clean         = "do a clean build? [off by default]";
  flag save          = "save the compiler database [save by default]";
  flag link          = "link the executable [link by default]";
  flag release       = "build a standalone release [off by default]";
  flag subprojects   = "build subprojects as well if necessary [on by default]";
  keyword build-script :: <file-locator> = "the (Jam) build script to use";
  keyword target :: <symbol> = "the target [dll or exe]";
  flag force         = "force relink the executable [off by default]";
  flag unify         = "combine the libraries into a single executable [off by default]";
end command-line build;

define method do-execute-command
    (context :: <environment-context>, command :: <build-project-command>)
 => ()
  let project = command.%project | context.context-project;
  let messages = if (release-internal?()) #"internal" else #"external" end;
  block ()
    if (build-project
	  (project,
	   process-subprojects?: command.%subprojects?, 
	   clean?:               command.%clean?,
	   link?:                #f,
	   save-databases?:      command.%save?,
	   messages:             messages,
	   output:               command.%output,
	   progress-callback:    curry(note-build-progress, context),
	   warning-callback:     curry(note-compiler-warning, context),
	   error-handler:        curry(compiler-condition-handler, context)))
      if (command.%link?)
	let project-context = context.context-project-context;
	let build-script
          = command.%build-script | project-context.context-build-script;
	link-project
	  (project,
	   build-script:         build-script,
	   target:               command.%target,
	   release?:             command.%release?,
	   force?:               command.%force?,
	   process-subprojects?: command.%subprojects?,
	   unify?:               command.%unify?,
	   messages:             messages,
	   progress-callback:    curry(note-build-progress, context),
	   error-handler:        curry(compiler-condition-handler, context))
      end;
      message(context, "Build of '%s' completed", project.project-name)
    else
      message(context, "Build of '%s' aborted",   project.project-name)
    end
  exception (error :: <file-system-error>)
    command-error("%s", error)
  end
end method do-execute-command;

define method note-build-progress
    (context :: <environment-context>, 
     position :: <integer>, range :: <integer>, 
     #key heading-label, item-label)
 => ()
  let project-context = context.context-project-context;
  // let last-heading = project-context.context-last-heading;
  // Let's not show headings
  // if (heading-label & ~empty?(heading-label) & heading-label ~= last-heading)
  //   project-context.context-last-heading := heading-label;
  //   message(context, "%s", heading-label)
  // end;
  let last-item-label = project-context.context-last-item-label;
  if (item-label & ~empty?(item-label) & item-label ~= last-item-label)
    project-context.context-last-item-label := item-label;
    message(context, "%s", item-label)
  end
end method note-build-progress;

define method note-compiler-warning
    (context :: <environment-context>, warning :: <warning-object>) => ()
  let project = context.context-project;
  let stream = context.context-server.server-output-stream;
  new-line(stream);
  print-environment-object-name(stream, project, warning, full-message?: #t);
  new-line(stream)
end method note-compiler-warning;

define method compiler-condition-handler
    (context :: <environment-context>,
     handler-type == #"project-not-found", 
     library :: <string>)
 => (filename :: false-or(<file-locator>))
  ignore(handler-type);
  choose-missing-project(context, library: library)
end method compiler-condition-handler;

define method compiler-condition-handler
    (context :: <environment-context>,
     handler-type == #"project-file-not-found", 
     filename :: <string>)
 => (filename :: false-or(<file-locator>))
  ignore(handler-type);
  choose-missing-project(context, filename: as(<file-locator>, filename))
end method compiler-condition-handler;

define function choose-missing-project
    (context :: <environment-context>,
     #key filename :: false-or(<file-locator>),
          library :: false-or(<string>))
 => (filename :: false-or(<file-locator>))
  let prompt
    = format-to-string("Project file for missing '%s':", 
		       filename | library | "unknown");
  command-line-choose-file(context.context-server, prompt: prompt)
end function choose-missing-project;

define method compiler-condition-handler
    (context :: <environment-context>,
     handler-type == #"link-error", message :: <string>)
 => (filename :: singleton(#f))
  command-error("Link failed: %s", message)
end method compiler-condition-handler;

define method compiler-condition-handler
    (context :: <environment-context>,
     handler-type == #"link-warning", warning-message :: <string>)
 => (filename :: singleton(#f))
  message(context, "%s", warning-message);
end method compiler-condition-handler;

define method compiler-condition-handler
    (context :: <environment-context>,
     handler-type == #"fatal-error", message :: <string>)
 => (filename :: singleton(#f))
  command-error("Fatal error: %s", message)
end method compiler-condition-handler;

define method compiler-condition-handler
    (context :: <environment-context>,
     handler-type == #"yes-no", 
     message :: <string>)
 => (yes? :: <boolean>)
  command-line-question(context.context-server, message)
end method compiler-condition-handler;


/// Link command

define class <link-project-command> (<abstract-link-command>)
end class <link-project-command>;

define command-line link => <link-project-command>
    (summary:       "links a project's executable",
     documentation: "Links the executable for a project.")
  optional project :: <project-object> = "the project to link";
  keyword build-script :: <file-locator> = "the (Jam) build script to use";
  keyword target :: <symbol> = "the target [dll or exe]";
  flag force       = "force relink the executable [off by default]";
  flag subprojects = "link subprojects as well if necessary [on by default]";
  flag unify       = "combine the libraries into a single executable [off by default]";
end command-line link;

define method do-execute-command
    (context :: <environment-context>, command :: <link-project-command>)
 => ()
  let project-context = context.context-project-context;
  let project = command.%project | context.context-project;
  let build-script
    = command.%build-script | project-context.context-build-script;
  let messages = if (release-internal?()) #"internal" else #"external" end;
  link-project(project,
	       build-script:         build-script,
	       target:               command.%target,
	       force?:               command.%force?,
	       process-subprojects?: command.%subprojects?,
	       unify?:               command.%unify?,
	       progress-callback:    curry(note-build-progress, context),
	       error-handler:        curry(compiler-condition-handler, context),
	       messages:             messages)
end method do-execute-command;


/// Remove Build Products command

define class <remove-build-products-command> (<project-command>)
  constant slot %project :: false-or(<project-object>) = #f,
    init-keyword: project:;
  constant slot %subprojects? :: <boolean> = #f,
    init-keyword: subprojects?:;
end class <remove-build-products-command>;

define command-line remove-build-products => <remove-build-products-command>
    (summary:       "remove the project's build products",
     documentation: "Removes the build products for a project.")
  optional project :: <project-object> = "the project";
  flag subprojects = "remove the build products for subprojects as well [off by default]";
end command-line remove-build-products;

define method do-execute-command
    (context :: <environment-context>, 
     command :: <remove-build-products-command>)
 => ()
  let project = command.%project | context.context-project;
  remove-project-build-products
    (project,
     process-subprojects?: command.%subprojects?,
     error-handler:        curry(compiler-condition-handler, context))
end method do-execute-command;


///---*** To do

/*
  compile-library
  remove-build-products
  make-release
  profile (the compiler)
  heap-statistics
  collect-garbage
  room
  break
  dood statistics
  trace-optimizations
*/


/// Build commands

define command-group build
    (summary: "project building commands",
     documentation: "Commands to drive project building.")
  property compiler-back-end;
  property compilation-mode;
  property build-script;
  command  build;
  command  link;
  command  remove-build-products;
end command-group build;