implementation module iTasks.API.Core.LayoutCombinators import StdTuple, StdList, StdBool, StdOrdList import Data.Maybe, Text, Data.Tuple, Data.List, Data.Either, Data.Functor import iTasks._Framework.Util, iTasks._Framework.HtmlUtil, iTasks._Framework.UIDefinition import iTasks.API.Core.Types, iTasks.API.Core.TaskCombinators from Data.Map import qualified put, get, del, newMap, toList from StdFunc import o, const from iTasks._Framework.Task import :: EventNo from iTasks._Framework.TaskState import :: TIMeta(..) derive gEq UISide autoLayoutRules :: LayoutRules autoLayoutRules = {accuInteract = autoAccuInteract, accuStep = autoAccuStep, accuParallel = autoAccuParallel, accuWorkOn = autoAccuWorkOn ,layoutSubEditor = autoLayoutSubEditor, layoutForm = autoLayoutForm, layoutBlocks = autoLayoutBlocks } /** * The basic interaction layout simply decorates the prompt and merges it with the editor. */ autoAccuInteract :: UIAttributes UIForm -> UIForm autoAccuInteract prompt editor //If the prompt attributes contain a hint attribute create a prompt # (prompt,pcontrols) = if (isJust ('Data.Map'.get HINT_ATTRIBUTE prompt)) ('Data.Map'.del HINT_ATTRIBUTE prompt,[(c,'Data.Map'.newMap) \\ c <-createPrompt prompt]) (prompt,[]) = {UIForm | attributes = mergeAttributes prompt editor.UIForm.attributes , controls = pcontrols ++ editor.UIForm.controls , size = editor.UIForm.size } autoAccuStep :: UIDef [UIAction]-> UIDef autoAccuStep {UIDef|content=UIEmpty {UIEmpty|actions},windows} stepActions = {UIDef|content=UIEmpty {UIEmpty|actions=actions ++ stepActions},windows=windows} autoAccuStep {UIDef|content=UIForm stack=:{UIForm|attributes,controls,size},windows} actions //Recognize special case of a complete empty interaction wrapped in a step as an actionset | isEmpty controls = {UIDef|content=UIEmpty {UIEmpty|actions=actions},windows=windows} //Promote to abstract container # (triggers,actions) = extractTriggers actions = addTriggersToUIDef triggers {UIDef|content=UIBlock {UIBlock|autoLayoutForm stack & actions = actions,size=size},windows=windows} autoAccuStep {UIDef|content=UIBlock sub=:{UIBlock|actions=[]},windows} stepActions //If an abstract container without actions is placed under a step container, we add the actions # (triggers,stepActions) = extractTriggers stepActions = addTriggersToUIDef triggers {UIDef|content=UIBlock {UIBlock|sub & actions = stepActions},windows=windows} autoAccuStep {UIDef|content=UIBlock sub=:{UIBlock|actions},windows} stepActions = {UIDef|content=UIBlock sub,windows=windows} autoAccuStep {UIDef|content=UIBlocks blocks origActions,windows} stepActions # (triggers,actions) = extractTriggers (origActions ++ stepActions) = addTriggersToUIDef triggers {UIDef|content=UIBlock (autoLayoutBlocks blocks actions),windows=windows} autoAccuParallel :: [UIDef] [UIAction] -> UIDef autoAccuParallel defs parActions # windows = flatten [windows \\ {UIDef|windows} <- defs] # (triggers,parActions) = extractTriggers parActions = case defs of [{UIDef|content=UIForm form}] # block = autoLayoutForm form = addTriggersToUIDef triggers {UIDef|content=UIBlock {UIBlock|block & actions = block.UIBlock.actions ++ parActions},windows=windows} [{UIDef|content=UIBlock block}] = addTriggersToUIDef triggers {UIDef|content=UIBlock {UIBlock|block & actions = block.UIBlock.actions ++ parActions},windows=windows} [{UIDef|content=UIEmpty {UIEmpty|actions}}] = addTriggersToUIDef triggers {UIDef|content=UIEmpty {UIEmpty|actions=actions ++ parActions},windows=windows} [def=:{UIDef|content=UIFinal _}] = addTriggersToUIDef triggers def _ | allForms defs # form = (foldl mergeForms {UIForm|attributes='Data.Map'.newMap,controls=[],size=defaultSizeOpts} defs) | isEmpty parActions = {UIDef|content=UIForm form,windows=windows} # block = autoLayoutForm form = addTriggersToUIDef triggers {UIDef|content=UIBlock {UIBlock|block & actions = block.UIBlock.actions ++ parActions},windows=windows} | otherwise # (blocks,actions) = foldr collectBlocks ([],[]) defs # content = case blocks of [block] = UIBlock {UIBlock|block & actions = block.UIBlock.actions ++ actions ++ parActions} //Not always a good idea :( _ = UIBlocks blocks (actions ++ parActions) = addTriggersToUIDef triggers {UIDef|content=content,windows=windows} where oneDef [d] = True oneDef _ = False allForms [] = True allForms [{UIDef|content=UIForm _}:fs] = allForms fs allForms _ = False mergeForms form1 {UIDef|content=UIForm form2} = {UIForm |attributes = mergeAttributes form1.UIForm.attributes form2.UIForm.attributes ,controls = form1.UIForm.controls ++ form2.UIForm.controls ,size = {UISizeOpts|form1.UIForm.size & width = maybe form1.UIForm.size.UISizeOpts.width Just form2.UIForm.size.UISizeOpts.width , height = maybe form1.UIForm.size.UISizeOpts.height Just form2.UIForm.size.UISizeOpts.height } } collectBlocks {UIDef|content=UIForm form} (blocks,actions) = ([autoLayoutForm form:blocks],actions) collectBlocks {UIDef|content=UIEmpty {UIEmpty|actions}} (blocks,actions1) = (blocks,actions ++ actions1) collectBlocks {UIDef|content=UIBlock block} (blocks,actions) = ([block:blocks],actions) collectBlocks {UIDef|content=UIBlocks blocks2 actions2} (blocks1,actions1) = (blocks2 ++ blocks1,actions2 ++ actions1) collectBlocks _ (blocks,actions) = (blocks,actions) /** * Overrule the title attribute with the title in the task meta data */ autoAccuWorkOn :: UIDef TaskAttributes -> UIDef autoAccuWorkOn def attributes # def = uiDefSetSize FlexSize FlexSize def = (maybe def (\title -> uiDefSetAttribute TITLE_ATTRIBUTE title def) ('Data.Map'.get "title" attributes)) /** * The basic data layout groups the controls of a part of a compound datastructure in a fieldset */ autoLayoutSubEditor :: UIForm -> [(UIControl,UIAttributes)] autoLayoutSubEditor {UIForm|controls=[]} = [] autoLayoutSubEditor {UIForm|controls=[c]} = [c] autoLayoutSubEditor {UIForm|attributes,controls} = [(defaultFieldSet ('Data.Map'.get LABEL_ATTRIBUTE attributes) (decorateControls controls),attributes)] autoLayoutForm :: UIForm -> UIBlock //Special case for choices autoLayoutForm {UIForm|attributes,controls=[(c=:UIListChoice _ _ ,_)],size} = {UIBlock|attributes=attributes,content={UIItemsOpts|defaultItemsOpts (/*createPrompt attributes ++*/ [fill c]) & direction=Vertical},actions=[],hotkeys=[],size=size} autoLayoutForm {UIForm|attributes,controls=[(c=:UITree _ _ _ ,_)],size} = {UIBlock|attributes=attributes,content={UIItemsOpts|defaultItemsOpts (/*createPrompt attributes ++*/ [fill c]) & direction=Vertical},actions=[],hotkeys=[],size=size} autoLayoutForm {UIForm|attributes,controls=[(c=:UIGrid _ _ _ ,_)],size} = {UIBlock|attributes=attributes,content={UIItemsOpts|defaultItemsOpts (/*createPrompt attributes ++*/ [fill c]) & direction=Vertical},actions=[],hotkeys=[],size=size} //General case autoLayoutForm {UIForm|attributes,controls,size} = {UIBlock|attributes=attributes,content={UIItemsOpts|defaultItemsOpts (/*createPrompt attributes ++*/ decorateControls controls) & direction=Vertical},actions=[],hotkeys=[],size=size} //Add labels and icons to a set of controls if they have any of those attributes set decorateControls :: [(UIControl,UIAttributes)] -> [UIControl] decorateControls controls = mapLst decorateControl controls where mapLst f [] = [] mapLst f [x] = [f True x] mapLst f [x:xs] = [f False x: mapLst f xs] decorateControl :: Bool (!UIControl,!UIAttributes) -> UIControl decorateControl last (control,attributes) # mbLabel = 'Data.Map'.get LABEL_ATTRIBUTE attributes # mbPrefix = 'Data.Map'.get PREFIX_ATTRIBUTE attributes # mbPostfix = 'Data.Map'.get POSTFIX_ATTRIBUTE attributes # mbHint = 'Data.Map'.get HINT_ATTRIBUTE attributes # mbValid = 'Data.Map'.get VALID_ATTRIBUTE attributes # mbWarning = 'Data.Map'.get WARNING_ATTRIBUTE attributes # mbError = 'Data.Map'.get ERROR_ATTRIBUTE attributes # hasMargin = hasMargin control # noMargins = noMarginControl control = case (mbLabel,mbPrefix,mbPostfix,mbHint,mbValid,mbWarning,mbError) of (Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing) //Just set margins | hasMargin = control = if noMargins (setMargins 0 0 0 0 control) (if last (setMargins 5 5 5 5 control) (setMargins 5 5 0 5 control)) _ //Add decoration # control = row (labelCtrl mbLabel ++ prefixCtrl mbPrefix ++ [control] ++ postfixCtrl mbPostfix ++ iconCtrl control mbHint mbValid mbWarning mbError) = if noMargins (setMargins 0 0 0 0 control) (if last (setMargins 5 5 5 5 control) (setMargins 5 5 0 5 control)) where row ctrls = (setSize FlexSize WrapSize o setDirection Horizontal) (defaultContainer ctrls) labelCtrl (Just label) = [setWidth (ExactSize 100) (stringDisplay label)] labelCtrl Nothing = [] postfixCtrl (Just postfix) = [setLeftMargin 5 (setWidth (ExactSize 30) (stringDisplay postfix))] postfixCtrl Nothing = [] prefixCtrl (Just prefix) = [setRightMargin 5 (setWidth (ExactSize 30) (stringDisplay prefix))] prefixCtrl Nothing = [] iconCtrl (UIEditCheckbox _ _) _ _ _ _ = [] iconCtrl _ (Just msg) _ _ _ = icon "icon-hint" msg iconCtrl _ _ (Just msg) _ _ = icon "icon-valid" msg iconCtrl _ _ _ (Just msg) _ = icon "icon-warning" msg iconCtrl _ _ _ _ (Just msg) = icon "icon-invalid" msg iconCtrl _ _ _ _ _ = [] icon cls tooltip = [setLeftMargin 5 (UIIcon defaultFSizeOpts {UIIconOpts|iconCls = cls, tooltip = Just tooltip})] hasMargin control = isJust (getMargins control) noMarginControl (UIPanel _ _ _) = True noMarginControl (UIGrid _ _ _) = True noMarginControl (UITree _ _ _) = True noMarginControl _ = False autoLayoutBlocks :: [UIBlock] [UIAction] -> UIBlock autoLayoutBlocks blocks actions = arrangeVertical blocks actions instance tune ToWindow where tune (ToWindow windowType vpos hpos) t = tune (AfterLayout (uiDefToWindow windowType vpos hpos)) t instance tune InPanel where tune InPanel t = tune (AfterLayout (uiDefSetAttribute CONTAINER_ATTRIBUTE "panel" o forceLayout)) t instance tune InContainer where tune InContainer t = tune (AfterLayout (uiDefSetAttribute CONTAINER_ATTRIBUTE "container" o forceLayout)) t instance tune FullScreen where tune FullScreen t = tune (AfterLayout (uiDefSetAttribute SCREEN_ATTRIBUTE "full" o forceLayout)) t instance tune Title where tune (Title title) t = tune (AfterLayout (uiDefSetAttribute TITLE_ATTRIBUTE title o forceLayout)) t instance tune Icon where tune (Icon icon) t = tune (AfterLayout (uiDefSetAttribute ICON_ATTRIBUTE icon o forceLayout )) t instance tune Attribute where tune (Attribute k v) t = tune (AfterLayout (uiDefSetAttribute k v o forceLayout)) t instance tune Label where tune (Label label) t = tune (AfterLayout (tweakControls (map (\(c,a) -> (c,'Data.Map'.put LABEL_ATTRIBUTE label a))))) t instance tune NoUserInterface where tune NoUserInterface (Task eval) = Task eval` where eval` event repOpts state iworld = eval event {repOpts & noUI = True} state iworld instance tune ForceLayout where tune ForceLayout t = tune (AfterLayout forceLayout) t forceLayout :: UIDef -> UIDef forceLayout {UIDef|content=UIForm form,windows} = {UIDef|content=UIBlock (autoLayoutForm form),windows=windows} forceLayout {UIDef|content=UIBlocks blocks actions,windows} = {UIDef|content=UIBlock (autoLayoutBlocks blocks actions),windows=windows} forceLayout def = def arrangeBlocks :: ([UIBlock] [UIAction] -> UIBlock) UIDef -> UIDef arrangeBlocks f {UIDef|content=UIForm form,windows} = {UIDef|content=UIBlock (f [autoLayoutForm form] []),windows=windows} arrangeBlocks f {UIDef|content=UIBlock block,windows} = {UIDef|content=UIBlock (f [block] []),windows=windows} arrangeBlocks f {UIDef|content=UIBlocks blocks actions,windows} = {UIDef|content=UIBlock (f blocks actions),windows=windows} arrangeBlocks f def = def instance tune ArrangeVertical where tune ArrangeVertical t = tune (AfterLayout (arrangeBlocks arrangeVertical)) t arrangeVertical :: UIBlocksCombinator arrangeVertical = arrangeStacked Vertical instance tune ArrangeHorizontal where tune ArrangeHorizontal t = tune (AfterLayout (arrangeBlocks arrangeHorizontal)) t arrangeHorizontal :: UIBlocksCombinator arrangeHorizontal = arrangeStacked Horizontal arrangeStacked :: UIDirection [UIBlock] [UIAction] -> UIBlock arrangeStacked direction blocks actions = foldl append {UIBlock|attributes='Data.Map'.newMap,content={UIItemsOpts|defaultItemsOpts [] & direction=direction},actions=actions,hotkeys=[],size=defaultSizeOpts} blocks where append ui1 ui2 # (control,attributes,actions,hotkeys) = blockToControl ui2 = {UIBlock|ui1 & content = {UIItemsOpts|ui1.UIBlock.content & items = ui1.UIBlock.content.UIItemsOpts.items ++ [control]} , actions = ui1.UIBlock.actions ++ actions , hotkeys = ui1.UIBlock.hotkeys ++ hotkeys , attributes = mergeAttributes ui1.UIBlock.attributes attributes } instance tune ArrangeWithTabs where tune ArrangeWithTabs t = tune (AfterLayout (arrangeBlocks arrangeWithTabs)) t arrangeWithTabs :: UIBlocksCombinator arrangeWithTabs = arrange where arrange blocks actions # parts = [(blockToTab ui,attributes) \\ ui=:{UIBlock|attributes} <- blocks] # tabs = map fst parts # activeTab = activeIndex parts # controls = [UITabSet defaultSizeOpts {UITabSetOpts|items=tabs,activeTab=activeTab}] = {UIBlock|attributes='Data.Map'.newMap,content={UIItemsOpts|defaultItemsOpts controls & direction=Vertical} ,actions=actions,hotkeys=[],size=defaultSizeOpts} activeIndex parts = find 0 Nothing parts where find i best [] = fmap fst best find i Nothing [(_,acur):ds] = find (i+1) (Just (i,acur)) ds find i (Just (ibest,abest)) [(_,acur):ds] | later acur abest = find (i+1) (Just (i,acur)) ds = find (i+1) (Just (ibest,abest)) ds later a b = case ('Data.Map'.get LAST_FOCUS_ATTRIBUTE a,'Data.Map'.get LAST_FOCUS_ATTRIBUTE b) of (Just fa,Just fb) = toInt fa > toInt fb (Just _,Nothing) = True _ = False instance tune ArrangeWithSideBar where tune (ArrangeWithSideBar index side size resize) t = tune (AfterLayout (arrangeBlocks (arrangeWithSideBar index side size resize))) t arrangeWithSideBar :: !Int !UISide !Int !Bool -> UIBlocksCombinator arrangeWithSideBar index side size resize = arrange where arrange [] actions = autoLayoutBlocks [] actions arrange blocks actions | index >= length blocks = autoLayoutBlocks blocks actions # sidePart = blocks !! index # restPart = case removeAt index blocks of [ui] = ui uis = autoLayoutBlocks uis [] # (sideC,sideAt,sideAc,sideHK) = blockToControl sidePart # (restC,restAt,restAc,restHK) = blockToControl restPart # sideC = if (side === TopSide|| side === BottomSide) (setSize FlexSize (ExactSize size) sideC) (setSize (ExactSize size) FlexSize sideC) # restC = fill restC = {UIBlock|attributes=mergeAttributes restAt sideAt ,content= {UIItemsOpts|defaultItemsOpts (if (side===TopSide || side === LeftSide) (if resize [sideC,UISplitter,restC] [sideC,restC]) (if resize [restC,UISplitter,sideC] [restC,sideC])) &direction = if (side===TopSide || side === BottomSide) Vertical Horizontal } ,actions = actions ++ restAc ++ sideAc ,hotkeys = restHK ++ sideHK ,size = defaultSizeOpts } instance tune ArrangeSplit where tune (ArrangeSplit direction resize) t = tune (AfterLayout (arrangeBlocks (arrangeSplit direction resize))) t arrangeSplit :: !UIDirection !Bool -> UIBlocksCombinator arrangeSplit direction resize = arrange where arrange [] actions = autoLayoutBlocks [] actions arrange blocks actions # (bcontrols,_,bactions,bhotkeys) = unzip4 (map blockToPanel blocks) # controls = map fill bcontrols # controls = if resize (intersperse UISplitter controls) controls = {UIBlock|attributes='Data.Map'.newMap ,content = {UIItemsOpts|defaultItemsOpts controls & direction = direction} ,actions = actions ++ flatten bactions ,hotkeys = flatten bhotkeys ,size = defaultSizeOpts } instance tune ArrangeCustom where tune (ArrangeCustom f) t = tune (AfterLayout (arrangeBlocks f)) t blockToControl :: UIBlock -> (UIControl,UIAttributes,[UIAction],[UIKeyAction]) blockToControl ui=:{UIBlock|attributes} = case ('Data.Map'.get CONTAINER_ATTRIBUTE attributes) of (Just "panel") = blockToPanel ui (Just "container") = blockToContainer ui _ = if (isNothing ('Data.Map'.get TITLE_ATTRIBUTE attributes)) (blockToContainer ui) (blockToPanel ui) blockToContainer :: UIBlock -> (UIControl,UIAttributes,[UIAction],[UIKeyAction]) blockToContainer {UIBlock|content=content=:{UIItemsOpts|items,direction},actions,attributes,size} //Add button actions # (buttons,hotkeys,actions) = actionsToButtons actions # (items,direction) = addButtonPanel attributes direction buttons items = (UIContainer sizeOpts {UIItemsOpts|content & items=items,direction=direction},attributes,actions,hotkeys) where sizeOpts = {UISizeOpts|size & width = Just FlexSize} blockToPanel :: UIBlock -> (UIControl,UIAttributes,[UIAction],[UIKeyAction]) blockToPanel {UIBlock|content=content=:{UIItemsOpts|items,direction},actions,attributes,size} //Add button actions # (buttons,hotkeys,actions) = actionsToButtons actions # (items,direction) = addButtonPanel attributes direction buttons items = (UIPanel sizeOpts {UIItemsOpts|content & items=items,direction=direction} panelOpts,attributes`,actions,hotkeys) where sizeOpts = {UISizeOpts|size & width = Just FlexSize} panelOpts = {UIPanelOpts|title = title,frame = False, hotkeys = Nothing, iconCls = iconCls} title = 'Data.Map'.get TITLE_ATTRIBUTE attributes iconCls = fmap (\icon -> "icon-" +++ icon) ('Data.Map'.get ICON_ATTRIBUTE attributes) attributes` = ('Data.Map'.del TITLE_ATTRIBUTE o 'Data.Map'.del ICON_ATTRIBUTE) attributes blockToTab :: UIBlock -> UITab blockToTab {UIBlock|content=content=:{UIItemsOpts|items,direction},actions,attributes,size} //Check for tab close action # (close,actions) = actionsToCloseId actions //Add button actions # (buttons,buttonkeys,actions) = actionsToButtons actions # (items,direction) = addButtonPanel attributes direction buttons items //Add menu actions # (menus,menukeys,actions) = actionsToMenus actions = (UITab {UIItemsOpts|content&items=items,direction=direction} (tabOpts (buttonkeys++menukeys) menus close)) where tabOpts hotkeys menus close = {UITabOpts|title = title, menu = if (isEmpty menus) Nothing (Just menus) , hotkeys = if (isEmpty hotkeys) Nothing (Just hotkeys), focusTaskId = taskId, closeTaskId = close,iconCls=iconCls} taskId = 'Data.Map'.get TASK_ATTRIBUTE attributes title = fromMaybe "Untitled" ('Data.Map'.get TITLE_ATTRIBUTE attributes) iconCls = fmap (\i -> "icon-" +++ i) ('Data.Map'.get ICON_ATTRIBUTE attributes) uiDefToWindow :: UIWindowType UIVAlign UIHAlign UIDef -> UIDef uiDefToWindow windowType vpos hpos {UIDef|content=UIForm form,windows} = {UIDef|content=UIEmpty {UIEmpty|actions=[]}, windows = [blockToWindow windowType vpos hpos (autoLayoutForm form):windows]} uiDefToWindow windowType vpos hpos {UIDef|content=UIBlock block,windows} = {UIDef|content=UIEmpty {UIEmpty|actions=[]}, windows = [blockToWindow windowType vpos hpos block:windows]} uiDefToWindow windowType vpos hpos {UIDef|content=UIBlocks blocks actions,windows} = {UIDef|content=UIEmpty {UIEmpty|actions=[]}, windows = [blockToWindow windowType vpos hpos (autoLayoutBlocks blocks actions):windows]} uiDefToWindow windowType vpos hpos def = def blockToWindow :: UIWindowType UIVAlign UIHAlign UIBlock -> UIWindow blockToWindow windowType vpos hpos {UIBlock|content=content=:{UIItemsOpts|items,direction},actions,attributes,size} //Check for window close action # (close,actions) = actionsToCloseId actions //Add button actions # (buttons,buttonkeys,actions) = actionsToButtons actions # (items,direction) = addButtonPanel attributes direction buttons items //Add menu actions # (menus,menukeys,actions) = actionsToMenus actions = UIWindow sizeOpts {UIItemsOpts|content&items=items,direction=direction} (windowOpts (buttonkeys++menukeys) menus close) where sizeOpts = {UISizeOpts|size & width = Just (fromMaybe WrapSize size.UISizeOpts.width), height = Just (fromMaybe WrapSize size.UISizeOpts.height)} windowOpts hotkeys menus close = {UIWindowOpts|windowType = windowType, title = title, menu = if (isEmpty menus) Nothing (Just menus), closeTaskId = close, focusTaskId = Nothing ,hotkeys = if (isEmpty hotkeys) Nothing (Just hotkeys), vpos = Just vpos, hpos = Just hpos, iconCls = iconCls} title = 'Data.Map'.get TITLE_ATTRIBUTE attributes iconCls = fmap (\icon -> "icon-" +++ icon) ('Data.Map'.get ICON_ATTRIBUTE attributes) autoLayoutFinal :: UIDef -> UIDef autoLayoutFinal {UIDef|content=UIEmpty {UIEmpty|actions},windows} = {UIDef|content=UIFinal (UIViewport (defaultItemsOpts []) {UIViewportOpts|title=Nothing,menu=Nothing,hotkeys=Nothing}),windows=windows} autoLayoutFinal {UIDef|content=UIForm stack,windows} = autoLayoutFinal {UIDef|content=UIBlock (autoLayoutForm stack),windows=windows} autoLayoutFinal {UIDef|content=UIBlock subui=:{UIBlock|attributes,content,actions,hotkeys,size},windows} # fullScreen = ('Data.Map'.get SCREEN_ATTRIBUTE attributes === Just "full") || isNothing ('Data.Map'.get "session" attributes) # (panel,attributes,actions,panelkeys) = blockToPanel (if fullScreen {UIBlock|subui & attributes = 'Data.Map'.del TITLE_ATTRIBUTE attributes} subui) # panel = if fullScreen (setSize FlexSize FlexSize panel) ((setSize WrapSize WrapSize o setFramed True) panel) # (menu,menukeys,actions) = actionsToMenus actions # items = [panel] # itemsOpts = {defaultItemsOpts items & direction = Vertical, halign = AlignCenter, valign= AlignMiddle} # hotkeys = case panelkeys ++ menukeys of [] = Nothing ; keys = Just keys = {UIDef|content=UIFinal (UIViewport itemsOpts {UIViewportOpts|title = 'Data.Map'.get TITLE_ATTRIBUTE attributes, menu = if (isEmpty menu) Nothing (Just menu), hotkeys = hotkeys}),windows=windows} autoLayoutFinal {UIDef|content=UIBlocks blocks actions,windows} = autoLayoutFinal {UIDef|content=UIBlock (autoLayoutBlocks blocks actions),windows=windows} autoLayoutFinal {UIDef|content=UIFinal viewport,windows} = {UIDef|content=UIFinal viewport,windows=windows} plainLayoutFinal :: UIDef -> UIDef plainLayoutFinal {UIDef|content=UIEmpty {UIEmpty|actions},windows} = {UIDef|content=UIFinal (UIViewport (defaultItemsOpts []) {UIViewportOpts|title=Nothing,menu=Nothing,hotkeys=Nothing}),windows=windows} plainLayoutFinal {UIDef|content=UIBlock block=:{UIBlock|attributes,content,actions,hotkeys},windows} # (UIContainer sOpts iOpts,attributes,_,_) = blockToContainer block = {UIDef|content=UIFinal (UIViewport iOpts {UIViewportOpts|title = 'Data.Map'.get TITLE_ATTRIBUTE attributes, menu = Nothing, hotkeys = Just hotkeys}),windows=windows} plainLayoutFinal {UIDef|content=UIBlocks blocks actions,windows} = plainLayoutFinal {UIDef|content=UIBlock (autoLayoutBlocks blocks actions),windows=windows} plainLayoutFinal {UIDef|content=UIFinal viewport,windows} = {UIDef|content=UIFinal viewport,windows=windows} //Wrap the controls of the prompt in a container with a nice css class and add some bottom margin createPrompt :: UIAttributes -> [UIControl] createPrompt attributes = case 'Data.Map'.get HINT_ATTRIBUTE attributes of Just hint = [UIContainer sizeOpts (itemsOpts hint)] Nothing = [] where sizeOpts = {defaultSizeOpts & margins = Just {top= 5, right = 5, bottom = 10, left = 5} , width = Just FlexSize, minWidth = Just WrapBound, height = Just WrapSize} itemsOpts hint = {UIItemsOpts|defaultItemsOpts [stringDisplay hint] & baseCls=Just "itwc-prompt"} //Adds a button panel to a set of controls //(not the prettiest code) addButtonPanel :: UIAttributes UIDirection [UIControl] [UIControl] -> (![UIControl],!UIDirection) addButtonPanel attr direction [] items = (items,direction) addButtonPanel attr direction buttons items = case ('Data.Map'.get "buttonPosition" attr,direction) of (Nothing,Vertical) = (items ++ [fillWidth (buttonPanel buttons)],Vertical) (Nothing,Horizontal) = ([setDirection Horizontal (defaultContainer items),fillWidth (buttonPanel buttons)],Vertical) (Just "left",Vertical) = ([wrapWidth (buttonPanel buttons),setDirection Vertical (defaultContainer items)],Horizontal) (Just "left",Horizontal) = ([wrapWidth (buttonPanel buttons):items],Horizontal) (Just "right",Vertical) = ([setDirection Vertical (defaultContainer items),wrapWidth (buttonPanel buttons)],Horizontal) (Just "right",Horizontal) = (items ++ [wrapWidth (buttonPanel buttons)],Horizontal) (Just "top",Vertical) = ([fillWidth (buttonPanel buttons):items],Vertical) (Just "top",Horizontal) = ([fillWidth (buttonPanel buttons),setDirection Horizontal (defaultContainer items)],Vertical) (Just "bottom",Vertical) = (items ++ [fillWidth (buttonPanel buttons)],Vertical) (Just "bottom",Horizontal) = ([setDirection Horizontal (defaultContainer items),fillWidth (buttonPanel buttons)],Vertical) addTriggersToUIDef :: [(Trigger,String,String)] UIDef -> UIDef addTriggersToUIDef triggers def=:{UIDef|content=content=:(UIForm stack=:{UIForm|controls})} = {UIDef|def & content = UIForm {UIForm|stack & controls = [(addTriggersToControl triggers c,m)\\ (c,m) <- controls]}} addTriggersToUIDef triggers def=:{UIDef|content=content=:(UIBlock subui)} = {UIDef|def & content = UIBlock (addTriggersToBlock triggers subui)} addTriggersToUIDef triggers def=:{UIDef|content=UIBlocks blocks actions} = {UIDef|def & content = UIBlocks (map (addTriggersToBlock triggers) blocks) []} addTriggersToUIDef triggers def = def addTriggersToBlock :: [(Trigger,String,String)] UIBlock -> UIBlock addTriggersToBlock triggers ui=:{UIBlock|content=content=:{UIItemsOpts|items}} = {UIBlock|ui & content = {UIItemsOpts|content & items = map (addTriggersToControl triggers) items}} addTriggersToControl :: [(Trigger,String,String)] UIControl -> UIControl //Recursive cases addTriggersToControl triggers (UIContainer sOpts iOpts=:{UIItemsOpts|items}) = UIContainer sOpts {UIItemsOpts|iOpts & items = map (addTriggersToControl triggers) items} addTriggersToControl triggers (UIPanel sOpts iOpts=:{UIItemsOpts|items} opts) = UIPanel sOpts {UIItemsOpts|iOpts & items = map (addTriggersToControl triggers) items} opts addTriggersToControl triggers (UITabSet sOpts tOpts=:{UITabSetOpts|items}) = UITabSet sOpts {UITabSetOpts|tOpts & items = map (addTriggersToTab triggers) items} //Single controls addTriggersToControl triggers control = foldr addTriggerToControl control triggers addTriggerToControl :: (Trigger,String,String) UIControl -> UIControl addTriggerToControl (DoubleClick,taskId,actionId) (UIGrid sOpts cOpts opts) = UIGrid sOpts cOpts {UIGridOpts|opts & doubleClickAction = Just (taskId,actionId)} addTriggerToControl (DoubleClick,taskId,actionId) (UITree sOpts cOpts opts) = UITree sOpts cOpts {UITreeOpts|opts & doubleClickAction = Just (taskId,actionId)} addTriggerToControl t c = c addTriggersToTab :: [(Trigger,String,String)] UITab -> UITab addTriggersToTab triggers (UITab iOpts=:{UIItemsOpts|items} opts) = (UITab {UIItemsOpts|iOpts & items = map (addTriggersToControl triggers) items} opts) //Container coercion toPanel :: !UIControl -> UIControl //Panels are left untouched toPanel ctrl=:(UIPanel _ _ _) = ctrl //Containers are coerced to panels toPanel ctrl=:(UIContainer sOpts iOpts) = UIPanel sOpts iOpts {UIPanelOpts|title=Nothing,frame=False,hotkeys=Nothing,iconCls=Nothing} //Uncoercable items are wrapped in a panel instead toPanel ctrl = defaultPanel [ctrl] toContainer :: !UIControl -> UIControl //Containers are left untouched toContainer ctrl=:(UIContainer _ _) = ctrl //Panels can be coerced to containers toContainer ctrl=:(UIPanel sOpts iOpts _) = UIContainer sOpts iOpts //Uncoercable items are wrapped in a container instead toContainer ctrl = defaultContainer [ctrl] //GUI combinators hjoin :: ![UIControl] -> UIControl hjoin items = UIContainer defaultSizeOpts {defaultItemsOpts items & direction = Horizontal, halign = AlignLeft, valign = AlignMiddle} vjoin :: ![UIControl] -> UIControl vjoin items = UIContainer defaultSizeOpts {defaultItemsOpts items & direction = Vertical, halign = AlignLeft, valign = AlignTop} //Container operations addItemToUI :: (Maybe Int) UIControl UIControl -> UIControl addItemToUI mbIndex item ctrl = case ctrl of UIContainer sOpts iOpts=:{UIItemsOpts|items} = UIContainer sOpts {UIItemsOpts|iOpts & items = add mbIndex item items} UIPanel sOpts iOpts=:{UIItemsOpts|items} opts = UIPanel sOpts {UIItemsOpts|iOpts & items = add mbIndex item items} opts _ = ctrl where add Nothing item items = items ++ [item] add (Just pos) item items = take pos items ++ [item] ++ drop pos items getItemsOfUI :: UIControl -> [UIControl] getItemsOfUI (UIContainer _ {UIItemsOpts|items}) = items getItemsOfUI (UIPanel _ {UIItemsOpts|items} _) = items getItemsOfUI ctrl = [ctrl] setItemsOfUI :: [UIControl] UIControl -> UIControl setItemsOfUI items (UIContainer sOpts iOpts) = UIContainer sOpts {UIItemsOpts|iOpts & items = items} setItemsOfUI items (UIPanel sOpts iOpts opts) = UIPanel sOpts {UIItemsOpts|iOpts & items = items} opts setItemsOfUI items ctrl = ctrl //Container for a set of horizontally layed out buttons buttonPanel :: ![UIControl] -> UIControl buttonPanel buttons = (wrapHeight o setPadding 2 2 2 0 o setDirection Horizontal o setHalign AlignRight) (setBaseCls "buttonbar" (defaultContainer buttons)) actionsToButtons :: ![UIAction] -> (![UIControl],![UIKeyAction],![UIAction]) actionsToButtons [] = ([],[],[]) actionsToButtons [a=:{taskId,action=action=:(Action name _),enabled}:as] # (buttons,hotkeys,actions) = actionsToButtons as = case split "/" name of //Action name consist of only one part -> make a button [name] = ([mkButton taskId action enabled:buttons],maybe hotkeys (\h -> [h:hotkeys]) (actionToHotkey a), actions) //Action name is "/" -> also make a button or we get a weird menu ["",""] = ([mkButton taskId action enabled:buttons],maybe hotkeys (\h -> [h:hotkeys]) (actionToHotkey a), actions) //Action name consists of multiple parts -> pass through _ = (buttons,hotkeys,[a:actions]) where mkButton taskId action=:(Action actionId _) enabled = UIActionButton defaultSizeOpts {UIActionOpts|taskId = toString taskId,actionId=actionId} {UIButtonOpts|text = Just (actionName action), iconCls = (actionIcon action), disabled = not enabled} actionsToMenus :: ![UIAction] -> (![UIControl],![UIKeyAction],![UIAction]) actionsToMenus actions # (menus,hotkeys,actions) = makeMenus [] [] actions = (sortBy menuOrder menus, hotkeys, actions) where makeMenus :: [UIControl] [UIKeyAction] [UIAction] -> ([UIControl],[UIKeyAction],[UIAction]) makeMenus menus hotkeys [] = (menus,hotkeys,[]) makeMenus menus hotkeys [a=:{taskId,action,enabled}:as] = makeMenus (addToMenus (path action) taskId action enabled menus) (addToHotkeys taskId action enabled hotkeys) as path action = case (split "/" (actionName action)) of ["":p] = p p = p addToMenus [main:item] taskId action enabled [] //Create menu = [createButton main item taskId action enabled] addToMenus [main:item] taskId action enabled [m=:(UIMenuButton sOpts opts):ms] //Add to existing menu if it exists | opts.UIMenuButtonOpts.text == Just main //Found! = [UIMenuButton sOpts {UIMenuButtonOpts|opts & menu = addToItems item taskId action enabled opts.UIMenuButtonOpts.menu}:ms] | otherwise = [m:addToMenus [main:item] taskId action enabled ms] addToMenus [main:item] taskId action enabled [m:ms] = [m:addToMenus [main:item] taskId action enabled ms] addToMenus _ taskId action enabled menus = menus addToItems [item:sub] taskId action enabled [] //Create item = [createItem item sub taskId action enabled] addToItems [item:sub] taskId action enabled [i:is] | itemText i == item | isEmpty sub //Duplicate item (just add it) = [i,createItem item sub taskId action enabled:is] | otherwise //Add to the found item = [addToItem sub taskId action enabled i:is] | otherwise = [i:addToItems [item:sub] taskId action enabled is] addToItems [] _ _ _ _ = [] itemText (UIActionMenuItem _ {UIButtonOpts|text}) = fromMaybe "" text itemText (UISubMenuItem {UIMenuButtonOpts|text}) = fromMaybe "" text itemText _ = "" createButton item [] taskId action enabled = UIActionButton defaultSizeOpts {UIActionOpts|taskId=taskId,actionId=actionName action} {UIButtonOpts|text=Just item,iconCls = actionIcon action, disabled = not enabled} createButton item sub taskId action enabled = UIMenuButton defaultSizeOpts {UIMenuButtonOpts |text = Just item ,iconCls = actionIcon action //Just (icon item) ,disabled = if (isEmpty sub) (not enabled) False ,menu = addToItems sub taskId action enabled [] } createItem item [] taskId action enabled //Action item = UIActionMenuItem {UIActionOpts|taskId=taskId,actionId=actionName action} {UIButtonOpts|text=Just item,iconCls = actionIcon action, disabled = not enabled} createItem item sub taskId action enabled //Sub item = UISubMenuItem { UIMenuButtonOpts | text = Just item , iconCls = actionIcon action , disabled = False , menu = addToItems sub taskId action enabled [] } addToItem sub taskId action enabled item=:(UISubMenuItem opts=:{UIMenuButtonOpts|menu}) = UISubMenuItem {UIMenuButtonOpts|opts & menu = addToItems sub taskId action enabled menu} addToHotkeys taskId action enabled hotkeys = case actionToHotkey {taskId=taskId,action=action,enabled=enabled} of Just hotkey = hotkeys ++ [hotkey] Nothing = hotkeys menuOrder (UIMenuButton _ {UIMenuButtonOpts|text=Just m1}) (UIMenuButton _ {UIMenuButtonOpts|text=Just m2}) = m1 < m2 menuOrder m1 m2 = False //Extract triggers from a list of actions extractTriggers :: ![UIAction] -> ([(Trigger,String,String)], [UIAction]) extractTriggers [] = ([],[]) extractTriggers [a=:{taskId,action=(Action name options)}:as] # (ts,as) = extractTriggers as = case [ t \\ ActionTrigger t <- options] of [] = (ts,[a:as]) triggers = ([(t,taskId,name) \\ t <- triggers] ++ ts, [{a & action= Action name (filter (not o isTrigger) options)}:as]) where isTrigger (ActionTrigger _) = True isTrigger _ = False actionsToCloseId :: ![UIAction] -> (!Maybe String, ![UIAction]) actionsToCloseId [] = (Nothing,[]) actionsToCloseId [{taskId,action=ActionClose,enabled}:as] = (if enabled (Just taskId) Nothing,as) actionsToCloseId [a:as] = let (mbtask,as`) = actionsToCloseId as in (mbtask,[a:as`]) actionToHotkey :: UIAction -> Maybe UIKeyAction actionToHotkey {taskId,action=Action actionId options,enabled=True} = case [key \\ ActionKey key <- options] of [key:_] = Just (key,{taskId=taskId,actionId=actionId}) _ = Nothing actionToHotkey _ = Nothing hasWindowContainerAttr :: UIAttributes -> Bool hasWindowContainerAttr attributes = maybe False ((==) "window") ('Data.Map'.get CONTAINER_ATTRIBUTE attributes) hasPanelContainerAttr :: UIAttributes -> Bool hasPanelContainerAttr attributes = maybe False ((==) "panel") ('Data.Map'.get CONTAINER_ATTRIBUTE attributes) hasContainerContainerAttr :: UIAttributes -> Bool hasContainerContainerAttr attributes = maybe False ((==) "container") ('Data.Map'.get CONTAINER_ATTRIBUTE attributes) hasContainerAttr :: UIAttributes -> Bool hasContainerAttr attributes = isJust ('Data.Map'.get CONTAINER_ATTRIBUTE attributes) singleControl :: UIDef -> Bool singleControl def = case uiDefControls def of [_] = True _ = False mergeAttributes :: UIAttributes UIAttributes -> UIAttributes mergeAttributes attr1 attr2 = foldl setIfNotSet attr1 ('Data.Map'.toList attr2) where setIfNotSet attr (k,v) = maybe ('Data.Map'.put k v attr) (const attr) ('Data.Map'.get k attr) tweakUI :: (UIControl -> UIControl) UIDef -> UIDef tweakUI f {UIDef|content=UIForm stack=:{UIForm|controls},windows} = {UIDef|content=UIForm {UIForm|stack & controls = [(f c,a) \\ (c,a) <- controls]},windows=windows} tweakUI f {UIDef|content=UIBlock sub=:{UIBlock|content=content=:{UIItemsOpts|items}},windows} = {UIDef|content=UIBlock {UIBlock|sub & content = {UIItemsOpts|content & items = map f items}},windows=windows} tweakUI f {UIDef|content=UIFinal (UIViewport iOpts=:{UIItemsOpts|items} opts),windows} = {UIDef|content=UIFinal (UIViewport {UIItemsOpts|iOpts & items = (map f items)} opts),windows=windows} tweakUI f def = def tweakAttr :: (UIAttributes -> UIAttributes) UIDef -> UIDef tweakAttr f {UIDef|content=UIForm stack=:{UIForm|attributes},windows} = {UIDef|content=UIForm {UIForm|stack & attributes = f attributes},windows=windows} tweakAttr f {UIDef|content=UIBlock sub=:{UIBlock|attributes},windows} = {UIDef|content=UIBlock {UIBlock|sub & attributes = f attributes},windows=windows} tweakAttr f def = def tweakControls :: ([(UIControl,UIAttributes)] -> [(UIControl,UIAttributes)]) UIDef -> UIDef tweakControls f {UIDef|content=UIForm stack=:{UIForm|controls},windows} = {UIDef|content=UIForm {UIForm|stack & controls = f controls},windows=windows} tweakControls f {UIDef|content=UIBlock sub=:{UIBlock|content=content=:{UIItemsOpts|items}},windows=windows} = {UIDef|content=UIBlock {UIBlock|sub & content = {UIItemsOpts|content & items = map fst (f [(c,'Data.Map'.newMap) \\ c <- items])}},windows=windows} tweakControls f {UIDef|content=UIFinal (UIViewport iOpts=:{UIItemsOpts|items} opts),windows} = {UIDef|content=UIFinal (UIViewport {UIItemsOpts|iOpts & items = map fst (f [(c,'Data.Map'.newMap) \\ c <- items])} opts),windows=windows} tweakControls f def = def