X-Git-Url: https://gerrit.simantics.org/r/gitweb?a=blobdiff_plain;f=bundles%2Forg.simantics.modeling.ui%2Fscl%2FSimantics%2FTesting%2FActionBrowseContext.scl;fp=bundles%2Forg.simantics.modeling.ui%2Fscl%2FSimantics%2FTesting%2FActionBrowseContext.scl;h=471a83ef9cf8b84d865ba95921e2b6485315653a;hb=969bd23cab98a79ca9101af33334000879fb60c5;hp=0000000000000000000000000000000000000000;hpb=866dba5cd5a3929bbeae85991796acb212338a08;p=simantics%2Fplatform.git

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