F# port of the "Build your own react - Didact" tutorial

Didact.fsx

(*
F# port of https://github.com/pomber/didact
Copyright © 2022 Victor Peter Rouven Müller

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
*)

open System

module Dict =
    open System.Collections
    open System.Collections.Generic

    let inline contains key (dict: IDictionary) = dict.Contains key
    let inline keys (dict: IDictionary) = dict.Keys

module Object =
    let inline keys dict = Map.keys dict

type Deadline() =
    let it = System.DateTime.Now.AddMilliseconds 100

    member _.timeRemaining() =
        System.DateTime.Now - it
        |> fun it -> it.TotalMilliseconds

let inline (!==) a b = a <> b

let requestIdleCallback _ = ()

type UsefulStuff =
    static member inline (?) (map: Map<string, 'a>) (key: string) = map[key]

    static member inline isNull(a: ^T) =
        System.Object.Equals(Unchecked.defaultof< ^T>, a)

    static member inline (!)(a: bool) = not a
    static member inline (!)(a: ^T) = UsefulStuff.isNull a

let inline nil<'T> = Unchecked.defaultof<'T>

let inline (!) (a: ^T) =
    let inline call b (obj: ^M) =
        ((^T or ^M): (static member (!): ^T -> bool) (b))

    call a Unchecked.defaultof<UsefulStuff>

let inline (!!) (a: ^T) = !a |> not

type Arr<'T>(elements: 'T seq) =

    let inner = ResizeArray<'T>(elements)


    interface System.Collections.Generic.IEnumerable<'T> with
        member _.GetEnumerator() : System.Collections.Generic.IEnumerator<'T> = inner.GetEnumerator()
        member _.GetEnumerator() : System.Collections.IEnumerator = inner.GetEnumerator()

    new() = Arr(Seq.empty)

    member self.Item
        with get index =
            try
                inner[index]
            with
            | _ -> nil
        and set index value = inner[index] <- value

    member self.push item = inner.Add item
    static member op_Implicit(ls: List<'T>) = Arr(ls)


type Map<'a, 'b when 'a: comparison> with
    member self.children = self["children" |> box |> unbox<'a>]

type Props = Map<string, obj>

[<CustomEquality; NoComparison>]
type FiberTyp =
    | Function of (Props -> Element)
    | SomethingElse
    | Text of string
    member self.Invoke(arg) =
        match self with
        | Function (it) -> it (arg)
        | _ -> nil

    interface IEquatable<FiberTyp> with
        override self.Equals other =
            match self with
            | Function _ -> false
            | SomethingElse -> true

and IElement =
    interface
    end

and Element = { typ: FiberTyp; props: Props }

type Hook =
    { mutable state: obj
      queue: (obj -> obj) Arr }

let doms = ResizeArray<obj>()

type Fiber =
    { typ: FiberTyp
      props: Props
      parent: Fiber
      mutable effectTag: string
      mutable dom: Dom
      mutable alternate: Fiber
      mutable child: Fiber
      mutable sibling: Fiber
      mutable hooks: Hook Arr }
    static member op_Implicit(it: Option<Fiber>) = it |> Option.get

    static member nil =
        { typ = nil
          props = nil
          parent = nil
          effectTag = nil
          dom = nil
          alternate = nil
          child = nil
          sibling = nil
          hooks = nil }

and Child = { typ: FiberTyp }

and document =
    static member createTextNode _ = ()
    static member createElement typ : Dom = Dom()

and Dom() as self =
    do
        printfn "dom ctor"
        doms.Add self

    // let event = new Event()
    let onClick = new Event<unit>()
    let children = ResizeArray()
    member _.OnClickEvent = onClick
    member _.OnClick = onClick.Publish

    member self.addEventListener(eventType, fn: Handler<unit>) =
        printfn "Add event listener, typ: %O" eventType

        match eventType with
        | "click" ->
            printfn "Add on click"
            self.OnClick.AddHandler fn
        | _ -> ()

    member _.removeEventListener(eventType, obj) =
        printfn "remove event listener"

        match eventType with
        | "onClick" -> self.OnClick.RemoveHandler obj
        | _ -> ()

    member _.appendChild it = children.Add it

    member _.removeChild it =
        children.Remove it |> ignore
        doms.Remove it |> ignore

    member _.Item
        with get _ = ()
        and set (_: string) (_: obj) = ()

    static member op_Implicit(it: Option<Dom>) = it |> Option.get

let mutable nextUnitOfWork: Fiber = nil
let mutable currentRoot: Fiber = nil
let mutable wipRoot: Fiber = nil
let mutable wipFiber = nil
let mutable hookIndex = nil
let mutable deletions = Arr()

let rec createElement (typ, props: 'props, [<ParamArray>] children: Element []) : Element = { typ = typ; props = props }

and createDom (fiber: Fiber) =
    let dom = document.createElement (fiber.typ)
    updateDom (dom, Map.empty, fiber.props)
    dom

and isEvent = fun (key: string) -> key.StartsWith("on")

and isProperty = fun (key: string) -> key !== "children" && ! isEvent(key)

and isNew =
    fun (prev: Props, next: Props) (key: string) ->
        if prev |> Map.containsKey key then
            if next |> Map.containsKey key then
                prev[key] !== next[key]
            else
                true
        else
            true

and isGone =
    fun (prev: Props, next: Props) (key: string) -> !(next |> Map.containsKey key)

and updateDom (dom: Dom, prevProps: Props, nextProps: Props) =
    //Remove old or changed event listeners
    Object.keys (prevProps)
    |> Seq.filter (isEvent)
    |> Seq.filter (fun key ->
        !(nextProps |> Map.containsKey key)
        || isNew (prevProps, nextProps) (key))
    |> Seq.iter (fun name ->
        let eventType = name.ToLower().Substring(2)
        dom.removeEventListener (eventType, prevProps[name] :?> Handler<unit>))

    // Remove old properties
    Object.keys (prevProps)
    |> Seq.filter (isProperty)
    |> Seq.filter (isGone (prevProps, nextProps))
    |> Seq.iter (fun name -> dom[name] <- "")

    // Set new or changed properties
    Object.keys (nextProps)
    |> Seq.filter (isProperty)
    |> Seq.filter (isNew (prevProps, nextProps))
    |> Seq.iter (fun name -> dom[name] <- nextProps[name])

    // Add event listeners
    Object.keys (nextProps)
    |> Seq.filter (isEvent)
    |> Seq.filter (isNew (prevProps, nextProps))
    |> Seq.iter (fun name ->
        let eventType = name.ToLower().Substring(2)
        dom.addEventListener (eventType, nextProps[name] :?> Handler<unit>))


and commitRoot () =
    deletions |> Seq.iter (commitWork)
    commitWork (wipRoot.child)
    currentRoot <- wipRoot
    wipRoot <- Unchecked.defaultof<Fiber>

and commitWork (fiber: Fiber) =
    if !fiber then
        ()
    else
        let mutable domParentFiber: Fiber = fiber.parent
        printfn "fiber parent: %A" fiber.parent

        while (!domParentFiber.dom) do
            domParentFiber <- domParentFiber.parent

        let domParent: Dom = domParentFiber.dom
        printfn "dom parent: %A" domParent
        printfn "fiber: %A" fiber

        if (fiber.effectTag = "PLACEMENT" && !!fiber.dom) then
            domParent.appendChild (fiber.dom)
        else if (fiber.effectTag = "UPDATE" && !!fiber.dom) then
            updateDom (fiber.dom, fiber.alternate.props, fiber.props)
        else if (fiber.effectTag = "DELETION") then
            commitDeletion (fiber, domParent)

        commitWork (fiber.child)
        commitWork (fiber.sibling)


and commitDeletion (fiber, domParent: Dom) =
    if (!!fiber.dom) then
        domParent.removeChild (fiber.dom)
    else
        commitDeletion (fiber.child, domParent)

and render (element: Element, container) =
    wipRoot <-
        { dom = container
          props = Map["children", [ element ]]
          alternate = currentRoot
          typ = nil
          parent = nil
          effectTag = nil
          child = nil
          sibling = nil
          hooks = Arr() }

    deletions <- Arr()
    nextUnitOfWork <- wipRoot

and workLoop (deadline: Deadline) =
    printfn "work loop"
    let mutable shouldYield = false

    while (!!nextUnitOfWork && !shouldYield) do
        nextUnitOfWork <- performUnitOfWork (nextUnitOfWork)
        shouldYield <- deadline.timeRemaining () < 1


    if (!!nextUnitOfWork && !!wipRoot) then
        commitRoot ()

// requestIdleCallback (workLoop)

and performUnitOfWork (fiber: Fiber) =
    printfn "Performing unit of work"

    match fiber.typ with
    | Function fn -> updateFunctionComponent (fiber)
    | _ -> updateHostComponent (fiber)

    if (!!fiber.child) then
        fiber.child
    else
        let mutable nextFiber: Fiber = fiber
        let mutable res = Unchecked.defaultof<Fiber>

        while (!!nextFiber && !res) do
            if (!!nextFiber.sibling) then
                res <- nextFiber.sibling
            else
                nextFiber <- nextFiber.parent

        res

and updateFunctionComponent (fiber: Fiber) =
    printfn "updating function component"
    wipFiber <- fiber
    hookIndex <- 0
    wipFiber.hooks <- [] |> Arr
    let children = [ fiber.typ.Invoke(fiber.props) ]
    printfn "invoked child"
    reconcileChildren (fiber, children)


and useState<'T> (initial: 'T) =
    let oldHook: Hook =
        if (!!wipFiber.alternate && !!wipFiber.alternate.hooks) then
            wipFiber.alternate.hooks[hookIndex]
        else
            nil

    printfn "oldHook: %O" oldHook

    let hook =
        { state =
            if !!oldHook then
                oldHook.state
            else
                initial |> box
          queue = Arr() }

    let actions =
        if !!oldHook then
            oldHook.queue
        else
            Arr()

    actions
    |> Seq.iter (fun action -> hook.state <- action (hook.state))

    let setState =
        fun (action: 'T -> 'T) ->
            hook.queue.push (fun obj -> action (obj :?> 'T) |> box)

            wipRoot <-
                { Fiber.nil with
                    dom = currentRoot.dom
                    props = currentRoot.props
                    alternate = currentRoot }

            nextUnitOfWork <- wipRoot
            deletions <- Arr()

    wipFiber.hooks.push (hook)
    hookIndex <- hookIndex + 1
    (hook.state :?> 'T, setState)

and updateHostComponent (fiber) =
    printfn "updating host component"

    if (!fiber.dom) then
        fiber.dom <- createDom (fiber)

    reconcileChildren (fiber, fiber.props.children :?> Element list)

and reconcileChildren (wipFiber: Fiber, elements: Element list) =
    let mutable index = 0

    let mutable oldFiber: Fiber =
        if !!wipFiber.alternate then
            if !!wipFiber.alternate.child then
                wipFiber.alternate.child
            else
                nil
        else
            nil

    let mutable prevSibling = nil

    while (index < elements.Length || !!oldFiber) do
        let element: Element = elements[index]
        let mutable newFiber: Fiber = nil

        let sameType =
            !!oldFiber
            && !!element
            && element.typ = oldFiber.typ

        if (sameType) then
            newFiber <-
                { Fiber.nil with
                    typ = oldFiber.typ
                    props = element.props
                    dom = oldFiber.dom
                    parent = wipFiber
                    alternate = oldFiber
                    effectTag = "UPDATE" }

        if (!!element && !sameType) then
            newFiber <-
                { Fiber.nil with
                    typ = element.typ
                    props = element.props
                    parent = wipFiber
                    effectTag = "PLACEMENT" }

        if (!!oldFiber && !sameType) then
            oldFiber.effectTag <- "DELETION"
            deletions.push (oldFiber)
        else
            ()


        if (!!oldFiber) then
            oldFiber <- oldFiber.sibling
        else
            ()

        if (index = 0) then
            wipFiber.child <- newFiber
            ()
        elif (!!element) then
            prevSibling.sibling <- newFiber
            ()
        else
            ()

        prevSibling <- newFiber
        index <- index + 1

let inline (=>) a b = a, b

let counter () =
    let (state, setState) = useState (0)
    printfn "state: %A" state

    { Element.typ = FiberTyp.Text <| $"{state}"
      Element.props =
        Map<string, obj>["children" => (List.empty<Element> |> box)

                         "onClick"
                         => (Handler<unit> (fun _ () ->
                                 printfn "On click was called!"
                                 setState (fun c -> c + 1))
                             |> box)] }

// const element = <Counter />
// const container = document.getElementById("root")
let createElementFromFunction fn =
    { Element.typ =
        FiberTyp.Function
        <| (fun (props) ->
            printfn "props: %A" props
            fn ())
      Element.props = Map [| ("children", List.empty<Element> |> box) |] }

render (createElementFromFunction counter, Dom())

async {
    do! Async.Sleep 1000

    for i = 0 to 20 do
        try
            doms
            |> Seq.iter (fun it ->
                let dom = it :?> Dom
                printfn "dom: %O" it
                dom.OnClickEvent.Trigger())
        with
        | _ -> ()

        do! Async.Sleep 500
}
|> Async.Start

for i = 0 to 200 do
    workLoop (Deadline())
    Async.Sleep 100 |> Async.RunSynchronously