(* db.sml
 *
 * COPYRIGHT (c) 2014 The SML3d Project (http://sml3d.cs.uchicago.edu)
 * All rights reserved.
 *
 * We should use the SpecLoader.registry representation for the database.  Perhaps it will
 * need to be made closer to the DBXML representation, but there is no reason for yet another
 * representation of basically the same information!
 *)

structure DB : sig

    type db

    val toXML : db -> DBXMLRep.db
    val fromXML : DBXMLRep.db -> db

(* NOTE: probably don't need this function *)
  (* load the specifications for the database into the database.  If the database is not
   * empty, then the Fail exception is raised.
   *)
    val load : {
	  regFile : string,
	  api : string,		(* api to filter the registry *)
	  profile : string,	(* profile to filter the registry *)
	  extensions : string	(* string that is matched against "supported" attribute *)
	} -> db

  (* extend the first database with any additional definitions, etc. that are provided by
   * the second database.
   *)
    val extend : db * db -> unit

  end = struct

    structure X = DBXMLRep
    structure ATbl = AtomTable
    structure AMap = AtomMap
    structure ASet = AtomSet

    datatype db = DB of {
        registry : string,       	(* specification file pathname *)
	api : string,
	profile : string,
	extensions : string,
	types : X.ty AtomTable.hash_table,
	enums : X.enum AtomTable.hash_table,
	groups : X.enum_grp AtomTable.hash_table,
	commands : X.cmd AtomTable.hash_table,
	features : X.feature AtomTable.hash_table
      }

  (* check to see if a database is empty *)
    fun isEmpty (DB{types, enums, commands, ...}) =
          (ATbl.numItems types = 0) andalso (ATbl.numItems enums = 0)
            andalso (ATbl.numItems commands = 0)

  (* comparison function on atoms that we can use with ListMergeSort.sort to sort in ascending
   * lexical order.
   *)
    fun atomGT (a, b) = (case Atom.lexCompare(a, b)
           of GREATER => true
            | _ => false
          (* end case *))

    fun sortTableItems tbl = let
          fun gt ((key1, _), (key2, _)) = atomGT(key1, key2)
          in
            List.map #2 (ListMergeSort.sort gt (ATbl.listItemsi tbl))
          end

    fun toXML (DB content) = X.DB{
	    registry = #registry content,
	    api = #api content,
	    profile = #profile content,
	    extensions = #extensions content,
	    types = sortTableItems(#types content),
	    enums = sortTableItems(#enums content),
	    commands = sortTableItems(#commands content),
	    groups = sortTableItems(#groups content),
	    features = sortTableItems(#features content)
          }

    fun fromXML (X.DB content) = let
          val enums = ATbl.mkTable (List.length(#enums content), Fail "enums")
          val insEnum = ATbl.insert enums
          val types = ATbl.mkTable (List.length(#types content), Fail "types")
          val insTy = ATbl.insert types
          val commands = ATbl.mkTable (List.length(#commands content), Fail "functions")
          val insCmd = ATbl.insert commands
	  val groups = ATbl.mkTable (List.length(#groups content), Fail "groups")
	  val insGrp = ATbl.insert groups
	  val features = ATbl.mkTable (List.length(#features content), Fail "features")
	  val insFeature = ATbl.insert features
          in
          (* initialize tables *)
            List.app (fn (ty as {name, def}) => insTy(name, ty)) (#types content);
            List.app (fn (enum as {name, ty, value}) => insEnum(name, enum)) (#enums content);
	    List.app (fn (cmd as X.Cmd{name, ...}) => insCmd(name, cmd)) (#commands content);
	    List.app (fn (grp as X.EnumGrp{name, ...}) => insGrp(name, grp)) (#groups content);
	    List.app (fn (f as X.Feature{name, ...}) => insFeature(name, f)) (#features content);
            DB{
		registry = #registry content,
		api = #api content,
		profile = #profile content,
		extensions = #extensions content,
		types = types,
		enums = enums,
		commands = commands,
		groups = groups,
		features = features
              }
          end

(* obsolete
  (* create a new empty database by cloning the meta information from another database *)
    fun clone (DB content) = DB{
	    registry = #registry content,
	    api = #api content,
	    profile = #profile content,
	    extensions = #extensions content,
            types = ATbl.mkTable (ATbl.numItems(#types content), Fail "types"),
            enums = ATbl.mkTable (ATbl.numItems(#enums content), Fail "enums"),
            commands = ATbl.mkTable (ATbl.numItems(#commands content), Fail "commands"),
            groups = ATbl.mkTable (ATbl.numItems(#groups content), Fail "groups"),
	    features = ATbl.mkTable (ATbl.numItems(#features content), Fail "features")
          }
*)

  (* load the specifications for the database into the database. *)
    fun load {regFile, api, profile, extensions} = let
	(* load and check specification *)
	  val registry = SpecLoader.load{
		  regFile = regFile,
		  api = SOME api,
		  profile = SOME profile,
		  extensions = SOME extensions
		}
	  in
	    DB{
		registry = regFile,
		api = api,
		profile = profile,
		extensions = extensions,
		types = #types registry,
		enums = #enums registry,
		groups = #groups registry,
		commands = #commands registry,
		features = let
		  val tbl = ATbl.mkTable (List.length (#features registry), Fail "features")
		  val ins = ATbl.insert tbl
		  in
		    List.app (fn (f as X.Feature{name, ...}) => ins(name, f)) (#features registry);
		    tbl
		  end
	      }
	  end

    fun conflict msg = raise Fail(concat msg)

 (* extend the type table by the constants in ext *)
    fun extendTypes (base, ext) = let
          val findInBase = ATbl.find base
          val insertInBase = ATbl.insert base
          fun extend (ty as {name, def}) = (case findInBase name
                 of SOME ty' => if CType.same(def, #def ty')
                      then conflict[
                          "type ", Atom.toString name, " definition conflict"
                        ]
                      else ()
                  | NONE => insertInBase (name, ty)
                (* end case *))
          in
            ATbl.app extend ext
          end

 (* extend the enum table base by the enums in ext *)
    fun extendEnums (base : X.enum AtomTable.hash_table, ext) = let
          val findInBase = ATbl.find base
          val insertInBase = ATbl.insert base
	  fun extend (enum as {name, ty, value}) = (case findInBase name
		 of NONE => insertInBase(name, enum)
		  | SOME{ty=ty', value=value', ...} => let
		      val tyConflict = (case (ty, ty')
			     of (SOME ty, SOME ty') => not(CType.same(ty, ty'))
			      | (NONE, NONE) => false
			      | _ => true
			    (* end case *))
		      in
			if tyConflict orelse (value <> value')
			  then conflict[
			      "enum ", Atom.toString name, " value conflict"
			    ]
			  else ()
		      end
		(* end case *))
	  in
(* do we want to check for enums that have been removed? *)
            ATbl.app extend ext
	  end

  (* extend the command table by the definitions in ext *)
    fun extendCommands (base, ext) = let
          val findInBase = ATbl.find base
          val insertInBase = ATbl.insert base
	  fun extend (cmd as X.Cmd{name, remove, protos}) = (
		case findInBase name
		 of SOME(X.Cmd{protos=protos', ...}) => let
(* FIXME: extend remove *)
		    (* we need to add any new prototypes into the existing list.  Note that for
		     * the expected usage of the extend function, the "ext" table will not add
		     * prototypes, just commands.
		     *)
		      val protoSet = let (* set of base prototypes *)
			    fun ins (X.Proto{name, ...}, m) = ASet.add(m, name)
			    in
			      List.foldl ins ASet.empty protos'
			    end
(* NOTE: we may want to add a consistency check for the overlapping definitions! *)
		      val newProtos = List.filter
			    (fn (X.Proto{name, ...}) => not(ASet.member(protoSet, name)))
			      protos
		      in
			if List.null newProtos
			  then ()
			  else insertInBase(name, X.Cmd{name=name, remove=remove, protos=protos' @ newProtos})
		      end
		  | NONE => insertInBase(name, cmd)
		(* end case *))
	  in
            ATbl.app extend ext
	  end

 (* extend the enum-group table base by the constants in ext *)
    fun extendGroups (base, ext) = let
          val findInBase = ATbl.find base
          val insertInBase = ATbl.insert base
          fun extend (grp as X.EnumGrp{name=grpName, bitmask, consts}) = (
                case findInBase grpName
                 of SOME(X.EnumGrp{bitmask=b, consts=baseConsts, ...}) =>
                      if (bitmask <> b)
                        then conflict[
                            "enum group ", Atom.toString grpName, " bitmask conflict"
                          ]
                        else let
                        (* construct a set of the constants in base *)
                          val cSet = ASet.fromList baseConsts
                          fun match name = not(ASet.member(cSet, name))
                          in
                            case List.filter match consts
                             of [] => ()
                              | cs => insertInBase (grpName, X.EnumGrp{
                                    name = grpName,
                                    bitmask = bitmask,
                                    consts = baseConsts @ cs
                                  })
                            (* end case *)
                          end
                  | NONE => (* add the group to the base *)
                      insertInBase (grpName, grp)
                (* end case *))
          in
            ATbl.app extend ext
          end

  (* extend the list of features base by the list ext *)
    fun extendFeatures (base, ext) = let
          val findInBase = ATbl.find base
          val insertInBase = ATbl.insert base
	(* we extend the feature list by either extending a feature or by adding a new
	 * feature to the list.
	 *)
	  fun extend (f as X.Feature{name, version, types, enums, commands}) = (
		case findInBase name
		 of SOME(X.Feature{version=v', types=tys', enums=enums', commands=cmds', ...}) => let
		      fun extend' (base, ext) = let
			    val set = AtomSet.fromList base
			    in
			      List.filter (fn x => not(AtomSet.member(set, x))) ext
			    end
		      in
			if (version <> v')
			  then conflict["feature ", Atom.toString name, " has conflicting versions"]
			  else ();
			case (extend'(types, tys'), extend'(enums, enums'), extend'(commands, cmds'))
			 of ([], [], []) => () (* no change *)
			  | (newTys, newEnums, newCmds) => insertInBase (name, X.Feature{
				name = name, version = version,
				types = types @ newTys,
				enums = enums @ newEnums,
				commands = commands @ newCmds
			      })
			(* end case *)
		      end
		  | NONE => insertInBase (name, f)
		(* end case *))
	  in
	    ATbl.app extend ext
	  end

(*
          fun extend (cat as X.Category{name=catName, functs}) = (
                case findInBase catName
                 of SOME(X.Category{functs=baseFuns, ...}) => let
                    (* construct a map of the base functions *)
                      val baseMap = mkFunMap baseFuns
                      fun inBase (X.Fun{name, ...}) = AMap.inDomain(baseMap, name)
                    (* partition the extension functions into those that are possible updates
                     * of the functions in the base and those that are new.
                     *)
                      val (updateFns, newFns) = let
                            val (ufs, nfs) = List.partition inBase functs
                            val uMap = mkFunMap ufs
                            in
                              (uMap, nfs)
                            end
                    (* merge a base and extension version of an optional field *)
                      fun merge (name, fld, base, ext) = (case (base, ext)
                             of (NONE, _) => ext
                              | (SOME _, NONE) => base
                              | (SOME v1, SOME v2) =>
                                  if (v1 <> v2)
                                    then conflict[
                                        "function ", Atom.toString name, ": ",
                                        fld, " field has conflicting values"
                                      ]
                                    else ext
                            (* end case *))
                    (* check to see if a base function's definition is modified
                     * by the version in the extension.  We also make sure that alias
                     * functions are consistent with the canonical definition.
                     *)
                      fun update (baseFn as X.Fun{
                              name, alias=NONE, version, deprecated, retTy, params
                            }) = (case AMap.find (updateFns, name)
                             of NONE => baseFn
                              | SOME(X.Fun info) => let
                                  val version = merge (name, "version", version, #version info)
                                  val deprecated = merge (name, "deprecated", deprecated, #deprecated info)
                                  in
                                    X.Fun{
                                        name = name, version = version,
                                        alias = NONE,
                                        deprecated = deprecated,
                                        retTy = retTy,
                                        params = params
                                      }
                                  end
                          (* end case *))
                        | update (baseFn as X.Fun{
                              name, alias=SOME name', version, deprecated, retTy, params
                            }) = (case AMap.find (updateFns, name')
                             of NONE => baseFn
                              | SOME(X.Fun info) => let
                                (* want the alias to be consistent with the canonical version *)
                                  val version = merge (name, "version", version, #version info)
                                  val deprecated = merge (name, "deprecated", deprecated, #deprecated info)
                                  in
                                    X.Fun{
                                        name = name, version = version,
                                        alias = SOME name',
                                        deprecated = deprecated,
                                        retTy = retTy,
                                        params = params
                                      }
                                  end
                          (* end case *))
                      in
                        insertInBase (catName, X.Category{
                            name = catName,
                            functs = (List.map update baseFuns) @ newFns
                          })
                      end
                  | NONE => insertInBase (catName, cat)
                (* end case *))
          in
            ATbl.app extend ext
          end
*)

  (* extend the first database with any additional definitions, etc. that
   * are provided by the second database.
   *)
    fun extend (DB base, DB ext) = (
(* NOTE: maybe we should allow different spec files? *)
        (* check that the two databases are compatible *)
          if (#registry base <> #registry ext)
	  orelse (#api base <> #api ext)
	  orelse (#profile base <> #profile ext)
            then conflict["extend: database mismatch"]
            else ();
        (* extend the database tables *)
          extendTypes (#types base, #types ext);
          extendEnums (#enums base, #enums ext);
          extendCommands (#commands base, #commands ext);
	  extendGroups (#groups base, #groups ext);
	  extendFeatures (#features base, #features ext))

  end