module JSPlumbdemo import iTasks, Tasklet import Text.StringAppender, graph_to_sapl_string import sapldebug Start :: *World -> *World Start world = startEngine (workAs (AuthenticatedUser "root" [] Nothing) (manageWorklist taskletExamples)) world taskletExamples :: [Workflow] taskletExamples = [workflow "JSPlumb tasklet" "Simple JSPlumb tasklet" plumbtasklet] plumbtasklet :: Task Void plumbtasklet = mkInstanceId >>= \iid -> mkTask (iid, jsPlumbTasklet) targetOptions = {mkEndpoint & anchor = Just [toHtmlObject "TopCenter"] , maxConnections = Just -1 , isTarget = Just True , endpoint = Just [toHtmlObject "Dot",toHtmlObject {radius = 5}] , paintStyle = Just {fillStyle = "#66CC00"} } sourceOptions = {mkEndpoint & anchor = Just [toHtmlObject "BottomCenter"] , maxConnections = Just -1 , isSource = Just True , endpoint = Just [toHtmlObject "Dot",toHtmlObject {radius = 5}] , paintStyle = Just {fillStyle = "#EEDD00"} } :: EndPointOptions = { anchor :: Maybe [HtmlObject] , endpoint :: Maybe [HtmlObject] , enabled :: Maybe Bool , paintStyle :: Maybe FillStyle , hoverPaintStyle :: Maybe FillStyle , cssClass :: Maybe String , hoverClas :: Maybe String , source :: Maybe String , canvas :: Maybe HtmlObject , container :: Maybe String , connections :: Maybe [HtmlObject] , isSource :: Maybe Bool , maxConnections :: Maybe Int , dragOptions :: Maybe HtmlObject , connectorStyle :: Maybe FillStyle , connectorHoverStyle :: Maybe FillStyle , connector :: Maybe [HtmlObject] , connectorOverlays :: Maybe [HtmlObject] , connectorClass :: Maybe String , connectorHoverClass :: Maybe String , connectionDetachable :: Maybe Bool , isTarget :: Maybe Bool , dropOptions :: Maybe HtmlObject , reattach :: Maybe Bool , parameters :: Maybe HtmlObject } mkEndpoint :: EndPointOptions mkEndpoint = { anchor = Nothing , endpoint = Nothing , enabled = Nothing , paintStyle = Nothing , hoverPaintStyle = Nothing , cssClass = Nothing , hoverClas = Nothing , source = Nothing , canvas = Nothing , container = Nothing , connections = Nothing , isSource = Nothing , maxConnections = Nothing , dragOptions = Nothing , connectorStyle = Nothing , connectorHoverStyle = Nothing , connector = Nothing , connectorOverlays = Nothing , connectorClass = Nothing , connectorHoverClass = Nothing , connectionDetachable = Nothing , isTarget = Nothing , dropOptions = Nothing , reattach = Nothing , parameters = Nothing } :: Radius = {radius :: Int} :: FillStyle = {fillStyle :: String} :: PlumbState = {plumb :: Maybe HtmlObject} jsPlumbTasklet :: Tasklet PlumbState Void jsPlumbTasklet = { generatorFunc = jsPlumbGUI , resultFunc = \_ -> Value Void False , tweakUI = setTitle "JSPlumb Tasklet" } where jsPlumbGUI iid taskId Nothing iworld = jsPlumbGUI iid taskId (Just {plumb = Nothing}) iworld jsPlumbGUI iid _ (Just st) iworld # canvas = DivTag [IdAttr "plumb_canvas", StyleAttr "width:100%; height:100%"] [] # gui = { TaskletHTML | width = ExactSize 600 , height = ExactSize 600 , html = HtmlDef (html canvas) , eventHandlers = [HtmlEvent "tasklet" "init" onInit ,HtmlEvent "tasklet" "destroy" onDestroy ,HtmlEvent "tasklet" "afterlayout" onAfterLayout] } = (TaskletHTML gui, st, iworld) where onScriptLoad st _ _ d # (d, _) = setDomAttr d "plumb_canvas" "innerHTML" ("
Block 1
" +++ "
Block 2
") # (d, plumb) = jsPlumb d # (d, plumb, _) = runObjectMethod d plumb "ready" [createEventHandler onReady iid] = (d, {st & plumb = Just plumb}) onInit st iid e d # (d, plumb) = jsPlumb d | isUndefined plumb = (loadPlumbAPI iid e d, st) = onScriptLoad st iid e d onReady st iid e d # (d, plumb) = jsPlumb d # (d, plumb) = addEndpoint plumb "block1" targetOptions d # (d, plumb) = addEndpoint plumb "block1" sourceOptions d # (d, plumb) = addEndpoint plumb "block2" targetOptions d # (d, plumb) = addEndpoint plumb "block2" sourceOptions d # (d, plumb) = draggable plumb "block1" d # (d, plumb) = draggable plumb "block2" d = (d, plumb) loadPlumbAPI _ _ d = d nullEventHandler st _ _ d = (d, st) onDestroy st=:{plumb = Just plumb} _ _ d // clear generated stuff # (d, _) = setDomAttr d "plumb_canvas" "innerHTML" "" = (d, {st & plumb = Nothing}) onDestroy st _ _ d = (d, st) onAfterLayout st _ _ d = (d, st) jsPlumb :: *HtmlDocument -> *(*HtmlDocument,HtmlObject) jsPlumb d = findObject d "jsPlumb" bind :: HtmlObject String HtmlObject *HtmlDocument -> *(*HtmlDocument, HtmlObject) bind plumb event cb d # (d, p, _) = runObjectMethod d plumb "bind" [toHtmlObject event, toHtmlObject cb] = (d, p) addEndpoint :: HtmlObject String EndPointOptions *HtmlDocument -> *(*HtmlDocument,HtmlObject) addEndpoint plumb target opts d # (d, p, _) = runObjectMethod d plumb "addEndpoint" [toHtmlObject target, toHtmlObject opts] = (d, p) draggable :: HtmlObject String *HtmlDocument -> *(*HtmlDocument,HtmlObject) draggable plumb target d # (d, p, _) = runObjectMethod d plumb "draggable" [toHtmlObject target] = (d, p) //------------------------------------------------------------------------- ifValue pred (Value v _) | pred v = Just (return v) = Nothing ifStable (Value v True) = Just (return v) ifStable _ = Nothing returnC :: b (TaskValue a) -> Task b | iTask b returnC v _ = return v returnV :: (TaskValue a) -> Task a | iTask a returnV (Value v _) = return v