urpal.sml

(* $Id$
 *
 * Copyright (c) 2008 Timothy Bourke (University of NSW and NICTA)
 * All rights reserved.
 *
 * This program is free software; you can redistribute it and/or modify it
 * under the terms of the "BSD License" which is distributed with the
 * software in the file LICENSE.
 *
 * This program is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the BSD
 * License for more details.
 *)

structure Urpal :
sig
  val main : string * string list -> OS.Process.status
  val run: string -> OS.Process.status
end
=
let structure UP  = UppaalParse
          and UXML = UppaalXML
          and TIO  = TextIO
          and CMD  = Commands
in
  struct
  exception FailedCommand
        and NoInputFile

  fun abort ss = let in
      TIO.output (TIO.stdErr, String.concat (Settings.progName::":"::ss));
      TIO.output (TIO.stdErr, "\n");
      raise FailedCommand
    end

  fun readNta filename = let
      val uri = Uri.String2Uri filename
    in case UXML.parse uri
       of NONE      => abort [filename,
                          " is not a valid XML file or the dtd is invalid."]
        | SOME xnta => UP.parse (xnta, filename)
    end

  fun writeNta (filename, nta) = let
      fun makeStream (s, c) = (TIO.getOutstream s, c)
      val (strm, close) = makeStream (case filename of
                             NONE   => (TIO.stdOut, fn _=>())
                           | SOME n => (TIO.openOut n, TIO.StreamIO.closeOut))
    in ParsedNta.output strm nta; close strm end
    handle IO.Io {cause,...} => (Util.warn ["failed to write nta (",
                                            General.exnMessage cause, ")"])
                                before (raise FailedCommand)

  fun tryConfigFiles () = let
      fun tryDir (NONE, _, _) = NONE
        | tryDir (SOME d, subs, f) = let
              val dir=foldl (fn(f,d)=>OS.Path.joinDirFile{dir=d,file=f}) d subs
            in SOME (OS.Path.joinDirFile {dir=dir, file=f}) end

      fun loadFile NONE = ()
        | loadFile (SOME path) = let
          val ()= Util.debugOutline (fn()=>["seeking config file ",path,"..."])

          val inso = SOME (TextIO.getInstream (TextIO.openIn path))
                     before Util.debugOutline (fn()=>["found"])
                     handle IO.Io {cause, ...} => NONE before
                       Util.debugOutline (fn()=>["not found (",
                                                 General.exnMessage cause,")"])
        in
          ignore (Option.map
                    (SettingsRW.loadConfigFile TextIO.StreamIO.inputLine) inso)
        end

    in
      app loadFile [tryDir (Settings.prefix (), ["etc"], "urpalrc"),
                    tryDir (OS.Process.getEnv "HOME", [], ".urpalrc"),
                    SOME "urpalrc"]
    end

  fun testFlip (NONE, _) = abort ["no input file specified"]
    | testFlip (SOME inf,NONE) = TestTransFlip.runTest {input=inf,
                                                        output=TextIO.stdOut}
    | testFlip (SOME inf,SOME outf) = (let
           val ostrm = TextIO.openOut outf
         in
           TestTransFlip.runTest {input=inf, output=ostrm};
           TextIO.closeOut ostrm;
           OS.Process.success
         end
         handle IO.Io {cause, ...} => (Util.warn
           ["cannot write to '", outf, "': ",
            General.exnMessage cause]; OS.Process.failure))

  fun main (name, args) = let
      val _ = Util.debugIndent (Settings.Detailed,fn()=>["try config files..."])
      val _ = tryConfigFiles ()
      val _ = Util.debugOutdent (Settings.Detailed, fn()=>["done."])
      val (cmds, {inputfile, outputfile}) = CMD.processCommands args
      val _ = Settings.validate ()
      val freshEnv = SOME (CmdEnv.fromNta ParsedNta.emptyNta)

      fun doCmd (a as CMD.ScriptFile _, NONE)       = doCmd (a, freshEnv)
        | doCmd (CMD.ScriptFile filename, SOME env) = let
              val ins = TextIO.openIn filename
            in
              CmdLang.parse TextIO.StreamIO.inputLine
                            (env, TextIO.getInstream ins)
            end

        | doCmd (a as CMD.ScriptText _, NONE)       = doCmd (a, freshEnv)
        | doCmd (CMD.ScriptText script, SOME env)   =
              CmdLang.parse (fn""=>NONE|s=>SOME(s,"")) (env, script)

        | doCmd (a as CMD.ScriptTerminal, NONE)     = doCmd (a, freshEnv)
        | doCmd (CMD.ScriptTerminal, SOME env)      = let
              fun getLine ins = (TextIO.print "> ";
                                 TextIO.StreamIO.inputLine ins)
            in
              CmdLang.parse getLine (env, TextIO.getInstream TextIO.stdIn)
            end

        | doCmd (CMD.ConfigFile p, envo) = (let
              val ins = TextIO.getInstream (TextIO.openIn p)
            in SettingsRW.loadConfigFile TextIO.StreamIO.inputLine ins;
               TextIO.StreamIO.closeIn ins;
               envo
            end
            handle IO.Io {cause, ...} => (Util.warn ["reading ",p," failed (",
                                            General.exnMessage cause, ")"];
                                          raise FailedCommand))

        | doCmd (CMD.ConfigText t, envo) = envo before
                SettingsRW.loadConfigFile (fn""=>NONE|s=>SOME(s,"")) t

        | doCmd (CMD.ShowConfig, envo)   = envo before
                                           Settings.saveConfigFile TextIO.stdOut
        | doCmd (CMD.TestFlip, _) = (Util.warn
                      ["The test flip command must be used by itself."];
                      raise FailedCommand)

    in
      case cmds of
        [CMD.TestFlip] => testFlip (inputfile, outputfile)

      | _ => let
               val ntao      = Option.mapPartial readNta inputfile
               val inputEnvo = Option.map CmdEnv.fromNta ntao
               val outputfile= if isSome outputfile then outputfile
                                                    else inputfile
             in
               case foldl doCmd inputEnvo cmds of
                 NONE     => OS.Process.success
               | SOME env => (writeNta (outputfile, CmdEnv.toNta env);
                                        OS.Process.success)
             end
    end
    handle FailedCommand => OS.Process.failure
         | CmdLang.Failure => OS.Process.failure
         | e => Util.abort ["uncaught exception:", General.exnMessage e]
    
    fun run args = main (Settings.progName, String.tokens Char.isSpace args)

  end
end