An immutable database with reference entities, cascading deletes, undo buffers, serialization, and reactive variables

Database.fs

namespace Neural

type Id = System.String
type Id<'T> =
    | Id of Id
    override this.ToString () = match this with Id id -> id

type IEntity =
    abstract References : Id seq with get
    abstract DeleteReference : Id -> IEntity option
    abstract ChangeReferences : Map<Id, Id> -> IEntity

type Database<'T when 'T :> IEntity> =
    {
        RootId : Id
        Entities : Map<Id, IEntity>
    }
    [<Newtonsoft.Json.JsonIgnoreAttribute>]
    member this.Root = this.Entities.[this.RootId] :?> 'T
    [<Newtonsoft.Json.JsonIgnoreAttribute>]
    member this.HasRoot = this.Entities.ContainsKey this.RootId
    static member Empty () =
        {
            RootId = Id.Empty
            Entities = Map.empty
        }

module Data =
    let private dbError (message : string) (e : exn) = Log.ex message e

    let newGenericId () : Id = System.Guid.NewGuid().ToString()
    let newId<'T> () : Id<'T> = Id (newGenericId ())
    let inline getId<'T> (id : Id<'T>) : Id = match id with Id x -> x
    let getIds<'T> (entities : Id<'T> seq) : Id seq = if entities = null then Seq.empty else entities |> Seq.map getId
    let allIds db = db.Entities |> Seq.map (fun x -> x.Key) |> Set.ofSeq

    let noReferences : Id seq = Seq.empty
    let didntChange x : IEntity option = Some x
    let deleteReferences<'T when 'T :> IEntity> (r : Id) (a : Id<'T>[]) : Id<'T>[] =
        a |> Array.filter(function Id x -> x <> r)
    let changeReferences<'T when 'T :> IEntity> (m : Map<Id, Id>) (a : Id<'T>[]) : Id<'T>[] =
        a |> Array.map(function Id x -> Id m.[x])
    let changeReference<'T when 'T :> IEntity> (m : Map<Id, Id>) (a : Id<'T>) : Id<'T> =
        match a with Id x -> Id m.[x]
    let changeEntityReference (m : Map<Id, Id>) (a : Id) : Id =
        m.[a]
    let private reId db =
        let newIds =
            db.Entities
            |> Map.map (fun k v -> newGenericId ())
        let newEnts =
            db.Entities
            |> Seq.map (fun kv -> (newIds.[kv.Key], kv.Value.ChangeReferences newIds))
            |> Map.ofSeq
        let newRoot = 
            if newIds.ContainsKey db.RootId then newIds.[db.RootId]
            else Id.Empty
        { db with RootId = newRoot; Entities = newEnts }

    let rec private gatherReferences (ids : Id seq) db =
        let mutable result = ids |> Set.ofSeq
        let mutable needsScan = result
        let mutable scanned = Set.empty
        //printfn "BEGIN SCAN %A" db
        while needsScan.Count > 0 do
            //printfn "NEED %A" needsScan
            let ns = needsScan
            needsScan <- Set.empty
            for n in ns do
                //printfn "SCAN %A" n
                scanned <- scanned.Add n
                match db.Entities.TryFind n with
                | Some e ->
                    //printfn "SCANE %A" e
                    try
                        for r in e.References do
                            if not (result.Contains r) then
                                result <- result.Add r
                            if not (scanned.Contains r) && not (needsScan.Contains r) then
                                needsScan <- needsScan.Add r
                    with ex -> dbError "Failed to find references" ex
                | _ -> ()
        result

    and private garbageCollect (db : Database<_>) =
        if db.HasRoot then
            let reachable = gatherReferences (Seq.singleton db.RootId) db
            let toCollect = Set.difference (allIds db) reachable
            let newEnts =
                db.Entities
                |> Map.filter (fun k v -> not (toCollect.Contains k))
            if newEnts.Count = db.Entities.Count then db
            else { db with Entities = newEnts }
        else db

    let createDatabase<'T when 'T :> IEntity> (root : 'T) : Database<'T> =
        if Seq.isEmpty root.References |> not then
            failwith "Root objects must be empty when creating databases"
        let id = newId<'T> ()
        {
            RootId = getId id
            Entities = (getId id, root :> IEntity) |> Seq.singleton |> Map.ofSeq
        }

    /// Creates the entity in the database
    let create<'T, 'D when 'T :> IEntity and 'D :> IEntity> (e : 'T) (db : Database<'D>) =
        for r in e.References do
            if db.Entities.ContainsKey r |> not then
                failwithf "Cannot insert %A without first inserting its reference %A" e r
        let id = newId<'T> ()
        id, { db with Entities = db.Entities.Add (getId id, e) }

    /// Creates the entity in the database
    let insertAll<'T, 'D when 'T :> IEntity and 'D :> IEntity> (es : 'T[]) (db : Database<'D>) =
        let ids = ResizeArray<_>()
        let mutable ents = db.Entities
        for e in es do
            for r in e.References do
                if db.Entities.ContainsKey r |> not then
                    failwithf "Cannot insert %A without first inserting its reference %A" e r
            let id = newId<'T> ()
            ids.Add id
            ents <- ents.Add (getId id, e)
        ids.ToArray(), { db with Entities = ents }

    /// Determines whether an entity is stored in the database
    let exists (id : Id<'T>) db : bool =
        match id with Id id -> match db.Entities.TryFind id with
                               | Some (:? 'T) -> true
                               | _ -> false

    /// Reads a value from the database
    let read (id : Id<'T>) db : 'T =
        match id with Id id -> match db.Entities.TryFind id with
                               | Some (:? 'T as e) -> e
                               | Some x -> failwithf "Expected %A but was %A for id %A" typeof<'T> (x.GetType()) id
                               | None -> failwithf "No %A with id %A" typeof<'T> id

    /// Reads a value from the database
    let tryRead (id : Id<'T>) db : 'T option =
        match id with Id id -> match db.Entities.TryFind id with
                               | Some (:? 'T as e) -> Some e
                               | _ -> None

    /// Reads multiple values from the database
    let readAll (ids : Id<'T>[]) db : 'T[] =
        ids |> Array.map (fun x -> read x db)

    /// Reads multiple values from the database with their Id
    let readAllWithId (ids : Id<'T>[]) db : (Id<'T> * 'T)[] =
        ids |> Array.map (fun x -> (x, read x db))

    /// Reads a value from the database
    let readEntity (id : Id) db : IEntity = db.Entities.[id]

    /// Reads a value from the database
    let readAllEntitiesWithId (ids : Id seq) db : (Id * IEntity)[] =
        ids |> Seq.map (fun x -> (x, readEntity x db)) |> Array.ofSeq

    /// Updates the database to include the entity
    let updateRoot<'T when 'T :> IEntity> (e : 'T) (db : Database<'T>) =
        for r in e.References do
            if db.Entities.ContainsKey r |> not then
                failwithf "Cannot update %A without first inserting its reference %A" e r
        { db with Entities = db.Entities.Add (db.RootId, e) }

    /// Updates the database to include the entity
    let update<'T, 'D when 'T :> IEntity and 'D :> IEntity> (id : Id<'T>) (e : 'T) (db : Database<'D>) =
        for r in e.References do
            if db.Entities.ContainsKey r |> not then
                failwithf "Cannot update %A without first inserting its reference %A" e r
        { db with Entities = db.Entities.Add (getId id, e) }

    let updateEntity<'T, 'D when 'T :> IEntity and 'D :> IEntity> (id : Id<'T>) (f : 'T -> 'T) (db : Database<'D>) =
        let oe = read id db
        let e = f oe
        for r in e.References do
            if db.Entities.ContainsKey r |> not then
                failwithf "Cannot update %A without first inserting its reference %A" e r
        { db with Entities = db.Entities.Add (getId id, e) }

    let updateEntities<'T, 'D when 'T :> IEntity and 'D :> IEntity> (update : 'T -> 'T) (db : Database<'D>) : Database<'D> =
        let newEnts =
            db.Entities
            |> Map.map (fun k v ->
                match v with
                | :? 'T as l -> update l :> IEntity
                | _ -> v)
        { db with Entities = newEnts }

    let updateEntitiesWithIds<'T, 'D when 'T :> IEntity and 'D :> IEntity> (update : Id<'T> -> 'T -> 'T) (db : Database<'D>) : Database<'D> =
        let newEnts =
            db.Entities
            |> Map.map (fun k v ->
                match v with
                | :? 'T as l -> update (Id k) l :> IEntity
                | _ -> v)
        { db with Entities = newEnts }

    /// Cascade delete an entity from the database
    let rec delete (ids : Id seq) db =
        let mutable todel = List.ofSeq ids
        let mutable deleted = Set.empty
        let mutable r = db
        while todel.Length > 0 do
            let did = todel.Head
            if did = r.RootId then
                r <- { r with RootId = Id.Empty }
            deleted <- deleted.Add did
            todel <- todel.Tail
            let newEnts =
                r.Entities.Remove did
                |> Map.map (fun i x ->
                    try
                        if Seq.contains did x.References then
                            x.DeleteReference did
                        else Some x
                    with ex -> dbError "Failed to delete references" ex; Some x)
            let delEnts =
                newEnts
                |> Map.filter (fun id e -> Option.isNone e)
            let goodEnts =
                newEnts
                |> Map.filter (fun id e -> Option.isSome e)
            let newToDel =
                delEnts
                |> Seq.filter (fun x -> not (deleted.Contains x.Key))
                |> Seq.map (fun x -> x.Key)
                |> List.ofSeq
            todel <- List.append todel newToDel
            r <- { r with Entities = goodEnts |> Map.map (fun i x -> x.Value) }
        r
        |> garbageCollect

    let deleteAll<'T, 'D when 'T :> IEntity and 'D :> IEntity> (ids : Id<'T> seq) (db : Database<'D>) =
        db |> delete (ids |> getIds)

    let copy (ids : Id seq) db =
        let implicitReferences = gatherReferences ids db
        let toDelete = Set.difference (allIds db) implicitReferences
        let trimmedDb = delete toDelete db
        let copyDb = reId trimmedDb
        copyDb

    let cut (ids : Id seq) db =
        let implicitReferences = gatherReferences ids db
        let toDelete = Set.difference (allIds db) implicitReferences
        let trimmedDb = delete toDelete db
        let copyDb = reId trimmedDb
        let newDb = delete ids db
        (newDb, copyDb)

open Newtonsoft.Json

module private Json =
    type IdConverter () =
        inherit JsonConverter ()
        let mutable readers = Map.empty
        let mutable writers = Map.empty
        override this.CanConvert typ =
            typ.Name = "Id`1"
        override this.ReadJson (reader, objectType, existing, serializer) =
            let s = reader.Value :?> string
            let id = s
            let key = objectType.FullName
            match readers.TryGetValue key with
            | true, rd -> rd(id)
            | false, _ ->
                let meth = objectType.GetMethod ("NewId")
                let rd(id : Id) = meth.Invoke (null, [| id :> obj |])
                readers <- readers.Add (key, rd)
                rd(id)
        override this.WriteJson (writer, value, serializer) =
            let objectType = value.GetType()
            let key = objectType.FullName
            match writers.TryGetValue key with
            | true, wr -> wr(writer, value)
            | false, _ ->
                let prop = objectType.GetProperties() |> Seq.find (fun x -> x.Name = "Item")
                let wr(w : JsonWriter, o : obj) =
                    let s = prop.GetValue (o, null)
                    w.WriteValue s
                writers <- writers.Add (key, wr)
                wr(writer, value)
    let settings = new JsonSerializerSettings (TypeNameHandling = Newtonsoft.Json.TypeNameHandling.Auto,
                                               Formatting = Newtonsoft.Json.Formatting.Indented)
    do settings.Converters.Add (IdConverter ())

type Database<'T when 'T :> IEntity> with
    static member FromJson (json : string) =
        Newtonsoft.Json.JsonConvert.DeserializeObject<Database<'T>> (json, Json.settings)
    member this.ToJson () =
        Newtonsoft.Json.JsonConvert.SerializeObject (this, Json.settings)

type State<'T> (initialState : 'T) =
    let ev = new Event<_,_> ()
    let ev2 = new Event<_,_> ()
    let mutable value = initialState
    member this.Value
        with get () = value
        and set value' =
            ev2.Trigger (this, System.ComponentModel.PropertyChangingEventArgs ("Value"))
            value <- value'
            ev.Trigger (this, System.ComponentModel.PropertyChangedEventArgs ("Value"))
    [<CLIEvent>]
    member this.PropertyChanged = ev.Publish
    [<CLIEvent>]
    member this.PropertyChanging = ev2.Publish

    interface System.ComponentModel.INotifyPropertyChanging with
        member this.add_PropertyChanging(handler) = ev2.Publish.AddHandler(handler)
        member this.remove_PropertyChanging(handler) = ev2.Publish.RemoveHandler(handler)
    interface System.ComponentModel.INotifyPropertyChanged with
        member this.add_PropertyChanged(handler) = ev.Publish.AddHandler(handler)
        member this.remove_PropertyChanged(handler) = ev.Publish.RemoveHandler(handler)


type Undo<'T> =
    {
        Revisions : Revision<'T>[]
        Index : int
    }
    member this.Value = this.Revisions.[this.Index].Value

and Revision<'T> =
    {
        Value : 'T
        Title : string
    }

module Undo =
    let newUndo<'T> (initialValue : 'T) =
        {
            Revisions = [| { Value = initialValue; Title = "Initial" } |]
            Index = 0
        }
    let registerUndo undo title newValue =
        let r = { Value = newValue; Title = title }
        {
            Revisions = Array.append (Array.take (undo.Index + 1) undo.Revisions) [| r |]
            Index = undo.Index + 1
        }
    let doUndo undo =
        if undo.Index > 0 then
            { undo with Index = undo.Index - 1 }
        else
            undo
    let doRedo undo =
        if undo.Index + 1 < undo.Revisions.Length then
            { undo with Index = undo.Index + 1 }
        else
            undo

type Var<'T> (getter : unit -> 'T, setter : 'T -> unit) =
    let propertyChanged = Event<_, _> ()
    member this.Value
        with get () = getter ()
        and set x =
            try
                setter x
                this.OnValueChanged ()
            with ex ->
                Log.ex "Set Value" ex
    member this.OnValueChanged () =
        propertyChanged.Trigger (this, System.ComponentModel.PropertyChangedEventArgs ("Value"))
    [<CLIEvent>]
    member this.PropertyChanged = propertyChanged.Publish
    interface System.ComponentModel.INotifyPropertyChanged with
        member this.add_PropertyChanged(handler) = propertyChanged.Publish.AddHandler(handler)
        member this.remove_PropertyChanged(handler) = propertyChanged.Publish.RemoveHandler(handler)

type MappedVar<'T, 'U> (project : 'T -> 'U, unproject : 'T -> 'U -> 'T, variable : Var<'T>) as this =
    inherit Var<'U> ((fun () -> project variable.Value), (fun x -> variable.Value <- unproject variable.Value x))
    let sub = variable.PropertyChanged.Subscribe (fun e ->
        this.OnValueChanged ())

type OptionallyMappedVar<'T, 'U> (project : 'T -> 'U option, unproject : 'T -> 'U -> 'T, variable : Var<'T>) as this =
    inherit Var<'U option> ((fun () -> project variable.Value), (function Some x -> variable.Value <- unproject variable.Value x | _ -> ()))
    let sub = variable.PropertyChanged.Subscribe (fun e ->
        this.OnValueChanged ())

module Var =
    let map<'T, 'U> (project : 'T -> 'U) (unproject : 'T -> 'U -> 'T) (variable : Var<'T>) : Var<'U> =
        upcast MappedVar<'T, 'U> (project, unproject, variable)
    let omap<'T, 'U> (project : 'T -> 'U option) (unproject : 'T -> 'U -> 'T) (variable : Var<'T>) : Var<'U option> =
        upcast OptionallyMappedVar<'T, 'U> (project, unproject, variable)

Example.fs

type Thing =
    {
        OtherThings : Id<OtherThing>[]
        MoreThings : Id<AnotherThing>[]
        SomeValue : int
    }
    interface IEntity with
        override this.References = 
            [
                this.OtherThings |> getIds
                this.MoreThings |> getIds
            ]
            |> Seq.concat
        override this.DeleteReference r =
            { this with
                OtherThings = this.OtherThings |> deleteReferences r
                MoreThings = this.MoreThings |> deleteReferences r
            }
            :> IEntity
            |> Some
        override this.ChangeReferences r =
            { this with
                OtherThings = this.OtherThings |> changeReferences r
                MoreThings = this.MoreThings |> changeReferences r
            }
            :> IEntity