structure Location :> LOCATION =
struct

open Util Sql Init


(* Managing locations *)

type location = {id : int, parent : int option, name : string}

fun intOptFromSql v =
    if C.isNull v then
	NONE
    else
	SOME (C.intFromSql v)

fun mkLocationRow [id, parent, name] =
    {id = C.intFromSql id,
     parent = intOptFromSql parent,
     name = C.stringFromSql name}
  | mkLocationRow row = Init.rowError ("location", row)

val intOptToSql =
    fn NONE => "NULL"
     | SOME n => C.intToSql n

val intOptToSqlCompare =
    fn NONE => "IS NULL"
     | SOME n => "= " ^ C.intToSql n

fun addLocation (parent, name) =
    let
	val db = getDb ()
	val id = nextSeq (db, "LocationSeq")
    in
	C.dml db ($`INSERT INTO Location (id, parent, name)
                    VALUES (^(C.intToSql id), ^(intOptToSql parent), ^(C.stringToSql name))`);
	id
    end

fun lookupLocation id =
    let
	val c = getDb ()
    in
	(case C.oneOrNoRows c ($`SELECT id, parent, name FROM Location WHERE id = ^(C.intToSql id)`) of
	     NONE => raise Fail "Location not found"
	   | SOME r => mkLocationRow r)
    end

fun modLocation (loc : location) =
    let
	val db = getDb ()
    in
	ignore (C.dml db ($`UPDATE Location
			    SET parent = ^(intOptToSql (#parent loc)), name = ^(C.stringToSql (#name loc))
			    WHERE id = ^(C.intToSql (#id loc))`))
    end

fun deleteLocation id =
    ignore (C.dml (getDb ()) ($`DELETE FROM Location WHERE id = ^(C.intToSql id)`))

structure IntKey = struct
   type ord_key = int
   val compare = Int.compare
end

structure NM = BinaryMapFn(IntKey)

structure UserKey = struct
   type ord_key = Init.user
   fun compare (u1 : ord_key, u2 : ord_key) = String.compare (#name u1, #name u2)
end

structure US = BinarySetFn(UserKey)

fun mkLivesRow [loc, usr] =
    {loc = C.intFromSql loc, usr = C.intFromSql usr}
  | mkLivesRow row = Init.rowError ("lives", row)

fun countResidents () =
    let
	val db = getDb ()

	fun folder (row, count) =
	    let
		fun addToParents (id, count) =
		    let
			val count = NM.insert (count, id, (case NM.find (count, id) of
							       NONE => 1
							     | SOME n => n+1))
		    in
			case C.oneRow db ($`SELECT parent FROM Location WHERE id = ^(C.intToSql id)`) of
			    [p] => if C.isNull p then
				       count
				   else
				       addToParents (C.intFromSql p, count)
			  | r => Init.rowError ("Location.addToParents", r)
		    end

		val lives = mkLivesRow row
	    in
		addToParents (#loc lives, count)
	    end
    in
	C.fold db folder NM.empty ($`SELECT loc, usr FROM Lives`)
    end

fun recordResidents () =
    let
	val db = getDb ()

	fun mkRow row =
	    case row of
		loc :: rest => (C.intFromSql loc, mkUserRow rest)
	      | _ => Init.rowError ("recordResidents.mkRow", row)

	fun folder (row, count) =
	    let
		val (loc, user) = mkRow row

		fun addToParents (id, count) =
		    let
			val count = NM.insert (count, id, (case NM.find (count, id) of
							       NONE => US.singleton user
							     | SOME ns => US.add (ns, user)))
		    in
			case C.oneRow db ($`SELECT parent FROM Location WHERE id = ^(C.intToSql id)`) of
			    [p] => if C.isNull p then
				       count
				   else
				       addToParents (C.intFromSql p, count)
			  | r => Init.rowError ("Location.addToParents'", r)
		    end
	    in
		addToParents (loc, count)
	    end
    in
	C.fold db folder NM.empty ($`SELECT loc, id, name, rname, bal, joined, app, shares, paypal, checkout
				     FROM Lives JOIN WebUser ON usr = id`)
    end

fun residents loc =
    let
	val res = recordResidents ()
    in
	case NM.find (res, loc) of
	    NONE => []
	  | SOME us => US.foldr (op ::) [] us
    end

fun locationTree (root, lim) =
    let
	val db = getDb ()

	fun locationTree' (root, lim, acc) =
	    let
		fun folder (row, acc) =
		    let
			val loc = mkLocationRow row
		    in
			case lim of
			    SOME 0 => Util.ITEM loc :: acc
			  | _ =>
			    let
				val dec = case lim of
					      SOME n => SOME (n-1)
					    | NONE => NONE
			    in
				Util.ITEM loc :: Util.BEGIN :: locationTree' (SOME (#id loc), dec, Util.END :: acc)
			    end
		    end
	    in
		C.fold db folder acc ($`SELECT id, parent, name FROM Location
   				        WHERE parent ^(intOptToSqlCompare root)
				        ORDER BY name DESC`)
	    end
    in
	locationTree' (root, lim, [])
    end

fun locationTreeWithUser (root, lim, usr) =
    let
	val db = getDb ()

	val mkLocationRow' =
	    fn (mine :: rest) => (not (C.isNull mine), mkLocationRow rest)
	     | row => Init.rowError ("location'", row)

	fun locationTree' (root, lim, acc) =
	    let
		fun folder (row, acc) =
		    let
			val loc = mkLocationRow' row
		    in
			case lim of
			    SOME 0 => Util.ITEM loc :: acc
			  | _ =>
			    let
				val dec = case lim of
					      SOME n => SOME (n-1)
					    | NONE => NONE
			    in
				Util.ITEM loc :: Util.BEGIN :: locationTree' (SOME (#id (#2 loc)), dec, Util.END :: acc)
			    end
		    end
	    in
		C.fold db folder acc ($`SELECT loc, id, parent, name
					FROM Location LEFT OUTER JOIN Lives ON (id = loc AND usr = ^(C.intToSql usr))
   				        WHERE parent ^(intOptToSqlCompare root)
				        ORDER BY name DESC`)
	    end
    in
	locationTree' (root, lim, [])
    end

fun locationTreeWithCounts (root, lim) =
    let
	val count = countResidents ()
	fun numResidents id =
	    case NM.find (count, id) of
		NONE => 0
	      | SOME n => n

	val db = getDb ()

	fun locationTree' (root, lim, acc) =
	    let
		fun folder (row, acc) =
		    let
			val loc = mkLocationRow row
		    in
			case lim of
			    SOME 0 => Util.ITEM (numResidents (#id loc), loc) :: acc
			  | _ =>
			    let
				val dec = case lim of
					      SOME n => SOME (n-1)
					    | NONE => NONE
			    in
				Util.ITEM (numResidents (#id loc), loc) :: Util.BEGIN :: locationTree' (SOME (#id loc), dec, Util.END :: acc)
			    end
		    end
	    in
		C.fold db folder acc ($`SELECT id, parent, name
					FROM Location
   				        WHERE parent ^(intOptToSqlCompare root)
				        ORDER BY name DESC`)
	    end
    in
	locationTree' (root, lim, [])
    end


(* Checking who lives where *)

type lives = {usr : int, loc : int}

fun livesIn (usr, loc) =
    let
	val c = getDb ()
    in
	(case C.oneOrNoRows c ($`SELECT COUNT( * )
				    FROM Lives
				    WHERE loc = ^(C.intToSql loc)
				       AND usr = ^(C.intToSql usr)`) of
	     SOME[x] => not (C.isNull x) andalso C.intFromSql x <> 0
	   | _ => false)
    end


(* Managing who lives where *)

fun addToLocation (lives : lives) =
    let
	val usr = #usr lives
	val loc = #loc lives
    in
	if livesIn (usr, loc) then
	    ()
	else
	    ignore (C.dml (getDb ()) ($`INSERT INTO Lives (loc, usr)
					VALUES (^(C.intToSql loc), ^(C.intToSql usr))`))
    end

fun removeFromLocation (lives : lives) =
    let
	val usr = #usr lives
	val loc = #loc lives
    in
	ignore (C.dml (getDb ()) ($`DELETE FROM Lives
			            WHERE loc = ^(C.intToSql loc)
				       AND usr = ^(C.intToSql usr)`))
    end

fun residentsOneLevel loc =
    C.map (getDb ()) mkUserRow ($`SELECT id, name, rname, bal, joined, app, shares, paypal, checkout
				  FROM Lives, WebUser
				  WHERE loc = ^(C.intToSql loc)
				    AND usr = id
				  ORDER BY name`)

fun alreadyExists (parent, name) =
    case C.oneRow (getDb ()) ($`SELECT COUNT( * ) FROM Location
			        WHERE parent ^(intOptToSqlCompare parent)
			           AND name = ^(C.stringToSql name)`) of
	[n] => not (C.isNull n) andalso C.intFromSql n <> 0
      | r => Init.rowError ("Location.alreadyExists", r)

fun userLocations usr =
    C.map (getDb ()) mkLocationRow ($`SELECT id, parent, name FROM Location JOIN Lives ON loc = id
				      WHERE usr = ^(C.intToSql usr)
				      ORDER BY name`)

fun subLocations par =
    C.map (getDb ()) mkLocationRow ($`SELECT id, parent, name FROM Location
				      WHERE parent ^(intOptToSqlCompare par)
				      ORDER BY name`)

end