kiss-vscode/projects/nat-archive-tool/src/nat/Lib.kiss

// Lib is its own class because, while it would make sense to group its functions and macros in Archive.kiss,
// other files would not be able to (load "Archive.kiss") for the macro definitions without taking on Archive's constructor.

// External programs can load Lib.kiss with (loadFrom "nat-archive-tool" "src/nat/Lib.kiss")

(function _log [msg]
    (#when (or test debug) (print msg)))

(defMacro log [ui msg]
    (withEvalOnce [ui msg]
        (when ui
            (ui.displayMessage msg))
        (_log msg)))

(defMacro hasComponent [e componentType]
    `(.exists .components ,e ,(symbolName componentType)))

// Changes to the object returned by (readComponent) will not be saved! Use (withWritableComponents) for making changes
(defMacro readComponent [e componentType]
    `(let [componentData (dictGet (the Map<String,String> .components ,e) ,(symbolName componentType))]
        // (log null (+ "reading " componentData " as " ,(symbolName componentType) " for " .id ,e))
        (the nat.components ,componentType 
            // TODO add to the documentation a hint that macros should use fully qualified type paths so macro caller classes don't need to import everything
            (tink.Json.parse componentData))))

// Return either the desired component, or def if no such component exists
(defMacro readComponentOr [e componentType def]
    (withEvalOnce [e]
        (if (hasComponent e ,componentType)
                (readComponent e ,componentType)
            ,def)))

// TODO check not overwriting a component
(defMacro addComponent [archive e componentType c]
    (withEvalOnce [archive e c]
        (withWritableEntry archive e
            (log null (+ "adding " (the nat.components ,componentType c) " as " ,(symbolName componentType) " for " e.id))
            (dictSet e.components ,(symbolName componentType) (tink.Json.stringify (the nat.components ,componentType c)))
            e)))

(defMacro removeComponent [archive e componentType]
    (withEvalOnce [archive e]
        (withWritableEntry archive e
            (log null (+ "removing " ,(symbolName componentType) " component from " e.id))
            (e.components.remove ,(symbolName componentType))
            e)))

// Retrieve multiple components from an Entity with mutable access.
// All components will be serialized after the block is done.
(defMacro withWritableComponents [archive e bindings &body body]
    (let [bindingPairs
                (groups (expList bindings) 2 Throw)
            bindingList
                []
            saveList
                []
            retValSymbol
                (symbol)]
        (doFor [name type] bindingPairs
            (bindingList.push `&mut ,name)
            (bindingList.push `(readComponent ,e ,type))
            (saveList.push `(dictSet .components ,e ,(symbolName type) (tink.Json.stringify (the nat.components ,type ,name)))))
        `(let [,@bindingList
                ,retValSymbol {,@body}]
            ,@saveList
            (.refreshEntry ,archive ,e) // Check the entry in and out of systems when its components change
            ,retValSymbol)))

(defMacro withWritableEntry [archive e &body body]
    (let [retValSymbol
                (symbol)]
        `(let [,retValSymbol {,@body}]
            (.refreshEntry ,archive ,e)
            ,retValSymbol)))

// Create a system that selects Entries according to a single string component (i.e. Name or Author) matching the given value
(defMacro stringComponentSystem [componentType value process]
    `(new System
        (lambda [archive :nat.Entry e]
            ?(and (hasComponent e ,componentType)
                (= ,value (readComponent e ,componentType))))
        ,process))

(function :Array<String> tagList [:nat.Entry e]
    (if (hasComponent e Tags)
            (let [t (readComponent e Tags)]
                (collect (t.keys)))
        []))

(function :Array<String> componentList [:nat.Entry e]
    (for =>cType cId e.components cType))

(function tagsMatch [e tagsBoolExp]
    (BoolExpInterp.eval tagsBoolExp (tagList e)))

(function componentsMatch [:nat.Entry e componentsBoolExp]
    (BoolExpInterp.eval componentsBoolExp (componentList e)))

(function componentsAndTagsMatch [:nat.Entry e componentsAndTagsBoolExp]
    (BoolExpInterp.eval componentsAndTagsBoolExp (cast (concat (tagList e) (componentList e)))))

(defAlias &call catsMatch componentsAndTagsMatch)

(function addFiles [:nat.Archive archive :nat.Entry e :Array<String> files &opt leaveOriginalCopy]
    (withWritableEntry archive e
        (doFor file files
            (let [pathWithoutDir (haxe.io.Path.withoutDirectory file)]
                (unless (contains e.files pathWithoutDir)
                    (let [pathInArchive (joinPath archive.archiveDir "files" pathWithoutDir)]
                        (unless (sys.FileSystem.exists pathInArchive)
                            ((if leaveOriginalCopy sys.io.File.copy sys.FileSystem.rename)
                                file pathInArchive)))
                    (e.files.push pathWithoutDir))))))

(function removeFiles [:nat.Archive archive :nat.Entry e :Array<String> files]
    (withWritableEntry archive e
        (doFor file files
            (e.files.remove file))))

(function addTags [:nat.Archive archive :nat.Entry e :Array<String> tagsToAdd]
    (if (hasComponent e Tags)
            (withWritableComponents archive e [tags Tags]
                (doFor tag tagsToAdd (dictSet tags tag 1)))
        (addComponent archive e Tags (for tag tagsToAdd =>tag 1))))

(function removeTags [:nat.Archive archive :nat.Entry e :Array<String> tagsToRemove]
    (when (hasComponent e Tags)
        (withWritableComponents archive e [tags Tags]
            (doFor tag tagsToRemove (tags.remove tag)))))

(function :Float getScale [:nat.Entry e]
    (if (hasComponent e Images2)
            (let [i2 (readComponent e Images2)]
                (nth i2.imageScales i2.pinnedImageIndex))
        (if (hasComponent e Scale)
                (readComponent e Scale)
            1.0)))

(function addConnections [:nat.Archive archive :nat.Entry e :Array<nat.Entry> entriesToConnect]
    (if (hasComponent e Connections)
            (withWritableComponents archive e [conn Connections]
                (doFor e2 entriesToConnect (dictSet conn e2.id 1)))
        (addComponent archive e Connections (for e2 entriesToConnect =>e2.id 1)))
    e)

(function removeConnections [:nat.Archive archive :nat.Entry e :Array<nat.Entry> entriesToRemove]
    (when (hasComponent e Connections)
        (withWritableComponents archive e [conn Connections]
            (doFor e2 entriesToRemove (conn.remove e2.id))))
    e)

(function isEntry [o]
    (let [fields (Reflect.fields o)]
        (and (= fields.length 3)
            (apply and (for f ["id" "components" "files"] (contains fields f))))))