structure Convert = 
struct
    fun manglefilename s = s

    (* Lexer of stream *)
    fun createLexerStream (is : BasicIO.instream) =
	Lexing.createLexer (fn buff => fn n => Nonstdio.buff_input is buff 0 n)

    fun parseFile lexbuf = Parser.Seq Scanner.Token lexbuf

    val quiet = ref false
    fun chat s = if !quiet then ()
		 else (print s; print "\n")


    local 
	open Parser Substring
	val hasStruc = List.exists (fn STRUCTURE => true | _ => false)  
	val hasSig   = List.exists (fn SIGNATURE => true | _ => false)  
	val sign     = all "signature"
	val stru     = all "structure"
	val ends     = all "\nend\n"
	val isComment = isPrefix "(*"
	val allWS    = foldl (fn (c,res) => res andalso Char.isSpace c) true
    in 
	fun roll (s :: sl) = if isComment s then s :: ends :: sl
			     else if allWS s then s :: roll sl
				  else ends :: s :: sl
	  | roll _         = [ends]
  
	fun ending rollback sl =
	    if not rollback then ends :: sl
	    else roll sl

	fun toSub rollback seq subs =
	    let fun getSub x y = slice(subs,x,SOME(y-x))
		fun loop (SIGNATURE :: ts) acc = loop ts (sign :: acc)
		  | loop (STRUCTURE :: ts) acc = loop ts (stru :: acc)
		  | loop (MLSTUFF(x,y) :: ts) acc = loop ts (getSub x y :: acc)
		  | loop (COMMENT(x,y) :: ts) acc = loop ts (getSub x y :: acc)
		  | loop _ acc = acc
	    in  rev(ending rollback (loop seq []))
	    end
	
	fun unitname filename = Path.base(Path.file filename)

	fun addStruc withsig seq filename =
	    let val dev = TextIO.openIn filename
		val s   = all (TextIO.inputAll dev)
	    in  if hasStruc seq then string s
		else let val cont = toSub false seq s
			 val unit = unitname filename
			 val sign = if withsig then [" :> ",unit," = \nstruct\n"]
				    else [" = \nstruct\n"]
			 val beg = all(String.concat("structure "::unit::sign))
		     in  concat(beg :: cont)
		     end
	    end 

	fun addSig rollback seq filename =
	    let val dev = TextIO.openIn filename
		val s   = all (TextIO.inputAll dev)
	    in  if hasSig seq then string s
		else let val cont = toSub rollback seq s
			 val unit = unitname filename
			 val beg  = all("signature "^unit^" = \nsig\n")
		     in  concat(beg :: cont)
		     end
	    end
	
    end

    fun read filename =
	let	val is     = BasicIO.open_in filename
	    val lexbuf = createLexerStream is
	    val seq    = parseFile lexbuf
	    val _      = BasicIO.close_in is
	in  seq
	end

    fun write outdir filename content =
	let val filen = Path.concat(outdir, Path.file filename)
	    val dev   = TextIO.openOut filen 
	in  TextIO.output(dev, content)
	    ; TextIO.closeOut dev
	end

    fun dostuff doit filename outdir =
	let val seq = read filename
	    val cont = doit seq filename
	in  write outdir filename cont
	end

    fun hasSig filename =
	let val b = Path.base filename
	    val s = Path.joinBaseExt{base = b, ext = SOME"sig"}
	in  FileSys.access(s,[])
	end

    fun processfile rollback outdir filename = 
	(case Path.ext filename of
	     SOME"sig" => dostuff (addSig rollback) filename outdir
	   | SOME"sml" => dostuff (addStruc (hasSig filename)) filename outdir
	   | SOME"mlp" => dostuff (addStruc (hasSig filename)) filename outdir
	   | _         => print("Don't know how to handle "^filename^"\n"))
	handle Fail msg => app print ["Error processing file: ", filename,
				      "\n", msg, "\n"]
	     | OS.SysErr (msg, err) =>
	          let val msg = case err of 
		                    SOME e => OS.errorMsg e
				  | NONE   => msg
		  in
		      app print ["OS Error processing file: ",
				 filename, "\n", msg, "\n"]
		  end

    fun getOpt option def ls =
	let fun get (opt :: (rest as arg :: xs)) =
		if opt = option then (arg, xs)
		else let val (res, ls) = get rest
		     in  (res, opt :: ls)
		     end
	      | get ls = (def, ls)
	in  get ls
	end

    fun main args =
	let fun eq x y = x = y
	    val (rb, args) = List.partition (eq "-rollback") args
	    val rollback = not (null rb)
	    val (q, args)  = List.partition (eq "-q") args
	    val _ = quiet := not (null q)
	    fun outdir ("-D" :: d :: ls) = (d, ls)
	      | outdir (s :: ls)         = let val (d,ls) = outdir ls
					   in  (d, s::ls)
					   end
	      | outdir []                = (".",[])
	    val (dir, files) = getOpt "-D" "." args
	in  app (processfile rollback dir) files
	end

    val _ = 
	case CommandLine.arguments() of
	    [] => print "usage: convert [-rollback] [-D outdir] files\n"
	  | args => main args

end