Migrated source code from Simantics SVN

[simantics/platform.git] / bundles / org.simantics.modeling.ui / scl / Simantics / Testing / ActionBrowseContext.scl

diff --git a/bundles/org.simantics.modeling.ui/scl/Simantics/Testing/ActionBrowseContext.scl b/bundles/org.simantics.modeling.ui/scl/Simantics/Testing/ActionBrowseContext.scl
new file mode 100644 (file)
index 0000000..471a83e
--- /dev/null
+++ b/bundles/org.simantics.modeling.ui/scl/Simantics/Testing/ActionBrowseContext.scl
@@ -0,0 +1,133 @@
+import "Simantics/DB"\r
+import "Comparator"\r
+import "Map" as Map\r
+include "Simantics/Testing/BuiltinKeys" as BuiltinKeys\r
+import "Simantics/Testing/BrowseContext"\r
+import "Simantics/Ontologies"\r
+\r
+importJava "org.eclipse.jface.action.Action" where\r
+    data Action\r
+    \r
+    @JavaName getText\r
+    getActionText :: Action -> <Proc> String\r
+    \r
+    @JavaName getId\r
+    getActionId :: Action -> <Proc> String\r
+\r
+importJava "org.simantics.modeling.ui.actions.ModeledActions" where\r
+    """\r
+    Comparator for comparing Actions together. Handy for sorting\r
+    """\r
+    ACTION_COMPARATOR :: Comparator Action\r
+\r
+instance Eq Action where\r
+    a == b = compareWithComparator ACTION_COMPARATOR a b == 0\r
+\r
+instance Ord Action where\r
+    compare = compareWithComparator ACTION_COMPARATOR\r
+\r
+importJava "org.simantics.browsing.ui.model.actions.IActionCategory" where\r
+    """\r
+    Interface for storing Actions with ActionCategories\r
+    """\r
+    data IActionCategory\r
+    \r
+    @JavaName getLabel\r
+    """\r
+    Gives the label of the ActionCategory e.g. `New` or `Edit`\r
+    """\r
+    getIActionCateogryLabel :: IActionCategory -> <Proc> String\r
+    \r
+    @JavaName getPriority\r
+    """\r
+    Gives the priority of the current ActionCategory\r
+    """\r
+    getIActionCategoryPriority :: IActionCategory -> <Proc> Double\r
+    \r
+    @JavaName isSubmenu\r
+    """\r
+    Boolean value indicating if the category has submenu or not\r
+    """\r
+    isIActionCategorySubmenu :: IActionCategory -> <Proc> Boolean\r
+\r
+importJava "org.simantics.browsing.ui.model.actions.ActionBrowseContext" where\r
+    """\r
+    ActionBrowseContext holds all contributions related to given set of action browse contexts.\r
+    """\r
+    data ActionBrowseContext\r
+    \r
+    """\r
+    Gets all the actions for the given NodeContext\r
+    """\r
+    getActions :: ActionBrowseContext -> NodeContext -> [NodeContext] -> <ReadGraph> Map.T IActionCategory [Action]\r
+    @private\r
+    create :: [Resource] -> <ReadGraph> ActionBrowseContext\r
+\r
+importJava "org.simantics.browsing.ui.model.browsecontexts.BrowseContexts" where\r
+    toActionBrowseContextG :: Vector String -> <ReadGraph> ActionBrowseContext\r
+\r
+"""\r
+Creates a new ActionBrowseContext for the given Collection of Resources.\r
+"""\r
+createActionBrowseContext :: [Resource] -> <ReadGraph> ActionBrowseContext\r
+createActionBrowseContext resource = do\r
+    create resource\r
+\r
+"""\r
+Test function for browsing whole BrowseContext for all NodeContexts recursively. Also goes through ActionBrowseContexts\r
+"""\r
+browseAllContext :: BrowseContext -> NodeContext -> <Proc> ()\r
+browseAllContext browse node = do\r
+    children = syncRead $ \_ -> browseContextChildren browse node\r
+    lista = collectionToList children\r
+    if length lista > 0\r
+    then do\r
+        all = browseAllContext browse\r
+        map all lista\r
+        browseDeepImpl browse node\r
+    else browseDeepImpl browse node\r
+\r
+@private\r
+browseDeepImpl :: BrowseContext -> NodeContext -> <Proc> ()\r
+browseDeepImpl browse node = do\r
+    labeldecorator = syncRead $ \_ -> browseContextLabelDecorator browse node\r
+    stubbi = decorateLabelStub labeldecorator\r
+    labels = syncRead $ \_ -> browseContextLabel  browse node\r
+    Map.iter(\k v -> (stubbi k v)) labels\r
+    images = syncRead $ \_ -> browseContextImage browse node\r
+    state = syncRead $ \_ -> browseContextCheckedState browse node\r
+    imagedecorator = syncRead $ \_ -> browseContextImageDecorator browse node\r
+    res = getConstant node BuiltinKeys.INPUT\r
+    actioncontext = syncRead $ \_ -> createActionBrowseContext [PROJECT.ProjectActionContext]\r
+    actions = syncRead $ \_ -> getActions actioncontext node [node]\r
+    Map.iter (\k v -> do\r
+        laabel = getIActionCateogryLabel k\r
+        prioo = getIActionCategoryPriority k\r
+        subm = isIActionCategorySubmenu k\r
+        //print (laabel + " " + (show prioo) + " " + (show subm))\r
+        iter printActionDetails (sort v)\r
+    ) actions\r
+    modifier = syncRead $ \_ -> browseContextModifier browse node "single"\r
+    match modifier with\r
+        Nothing -> ()\r
+        Just modif -> do\r
+            val = getValue modif\r
+            valid = isValid modif val\r
+            ()\r
+\r
+@private\r
+printActionDetails :: Action -> <Proc> ()\r
+printActionDetails action = do\r
+    teext = getActionText action\r
+    iid = getActionId action\r
+    //print ("-- " + teext + " (" + iid + ")")\r
+    ()\r
+\r
+@private\r
+decorateLabelStub :: LabelDecorator -> String -> String -> <Proc> ()\r
+decorateLabelStub decorator key value = do\r
+    fontti = decorateFont decorator getDefaultFontDescriptor key 0\r
+    fontti = decorateBackground decorator Nothing key 0\r
+    fontti = decorateForeground decorator Nothing key 0\r
+    laabeli = decorateLabel decorator value key 0\r
+    ()\r