We planned to upgrade GitLab and Mattermost to the latest version this Friday morning (early). You may experience some downtime!

Commit 6c563df9 authored by Bas Lijnse's avatar Bas Lijnse

Generalized the tune combinators to make it applicable to editors too

parent add24c82
......@@ -28,6 +28,7 @@ import
, iTasks.WF.Combinators.Common
// Custom task GUI's
, iTasks.UI.Tune
, iTasks.UI.Editor.Controls
, iTasks.UI.Editor.Containers
, iTasks.UI.Editor.Modifiers
......
......@@ -12,7 +12,7 @@ import iTasks.Internal.IWorld, iTasks.Internal.WebService, iTasks.Internal.SDSSe
import qualified iTasks.Internal.SDS as SDS
import iTasks.UI.Layout, iTasks.UI.Layout.Default
from iTasks.WF.Combinators.Tune import class tune(..), instance tune ApplyLayout, :: ApplyLayout(..)
from iTasks.WF.Combinators.Tune import class tune(..), instance tune ApplyLayout Task, :: ApplyLayout(..)
from iTasks.SDS.Combinators.Common import sdsFocus
import StdInt, StdChar, StdString
......
......@@ -5,7 +5,7 @@ from iTasks.Internal.IWorld import :: IWorld, :: SystemClocks
from iTasks.Engine import :: PublishedTask
from iTasks.Internal.Task import :: TaskEvalOpts, :: TaskResult
from iTasks.WF.Definition import :: Task, :: InstanceNo, class iTask
from iTasks.WF.Combinators.Tune import class tune
from iTasks.UI.Tune import class tune
from iTasks.SDS.Definition import :: SDS
import iTasks.Internal.Tonic.AbsSyn
......
......@@ -81,3 +81,4 @@ withClientSideInit ::
((JSObj ()) *JSWorld -> *JSWorld)
(DataPath a *VSt -> *(!MaybeErrorString (!UI, !EditMask), !*VSt))
DataPath a *VSt -> *(!MaybeErrorString (!UI, !EditMask), !*VSt)
......@@ -2,7 +2,7 @@ definition module iTasks.UI.Editor.Modifiers
/**
* This module provides combinator functions for combining editors
*/
import iTasks.UI.Editor, iTasks.UI.Definition
import iTasks.UI.Editor, iTasks.UI.Definition, iTasks.UI.Tune
import Data.Error
//### Modifying atributes of editors ###
......@@ -11,6 +11,8 @@ import Data.Error
*/
withAttributes :: UIAttributes (Editor a) -> Editor a
instance tune UIAttributes Editor
/**
* Adds a label attribute
* This does not create the actual label ui component, that is normally done by a layout
......
implementation module iTasks.UI.Editor.Modifiers
import StdBool
import iTasks.UI.Editor, iTasks.UI.Definition
import iTasks.UI.Editor, iTasks.UI.Definition, iTasks.UI.Tune
import Data.Error, Text.JSON
import GenEq
import qualified Data.Map as DM
......@@ -14,6 +14,10 @@ where
(Ok (UI type attr items,mask),vst) = (Ok (UI type ('DM'.union attr extra) items,mask),vst)
(e,vst) = (e,vst)
instance tune UIAttributes Editor
where
tune attr editor = withAttributes attr editor
withLabelAttr :: String (Editor a) -> Editor a
withLabelAttr label editor = withAttributes (labelAttr label) editor
......
......@@ -7,7 +7,8 @@ definition module iTasks.UI.Layout.Common
import iTasks.UI.Layout
from iTasks.UI.Definition import :: UISide(..), :: UIDirection(..), :: UIWindowType(..), :: UIHAlign(..), :: UIVAlign(..)
from iTasks.UI.Prompt import :: Title, :: Label, :: Icon
from iTasks.WF.Combinators.Tune import class tune
from iTasks.UI.Tune import class tune
from iTasks.WF.Definition import :: Task
/**
* Create a tabset with all child items as separate tabs
......@@ -62,19 +63,19 @@ insertToolBar :: [String] -> Layout
//Convenient annotatation types
:: ArrangeWithTabs = ArrangeWithTabs
instance tune ArrangeWithTabs
instance tune ArrangeWithTabs Task
:: ArrangeWithSideBar = ArrangeWithSideBar !Int !UISide !Int !Bool
instance tune ArrangeWithSideBar
instance tune ArrangeWithSideBar Task
:: ArrangeSplit = ArrangeSplit !UIDirection !Bool
instance tune ArrangeSplit
instance tune ArrangeSplit Task
:: ArrangeVertical = ArrangeVertical
instance tune ArrangeVertical
instance tune ArrangeVertical Task
:: ArrangeHorizontal = ArrangeHorizontal
instance tune ArrangeHorizontal
instance tune ArrangeHorizontal Task
//Changing container types
......@@ -87,23 +88,23 @@ toEmpty :: Layout
InWindow :== InFloatingWindow
InFloatingWindow :== ToWindow FloatingWindow AlignMiddle AlignCenter
InNotificationBubble :== ToWindow NotificationBubble AlignTop AlignRight
instance tune ToWindow
instance tune ToWindow Task
:: InPanel = InPanel //Indicate that a task should be wrapped in a panel
instance tune InPanel
instance tune InPanel Task
:: InContainer = InContainer //Indicate that a task should be wrapped in a panel
instance tune InContainer
instance tune InContainer Task
:: NoUserInterface = NoUserInterface //Replace the UI by an empty UI
instance tune NoUserInterface
instance tune NoUserInterface Task
actionToButton :: Layout
setActionIcon :: (Map String String) -> Layout
//Setting attributes
instance tune Title
instance tune Label
instance tune Icon
instance tune Title Task
instance tune Label Task
instance tune Icon Task
......@@ -123,51 +123,51 @@ where
>>= \(JSONString actionId) -> 'DM'.get actionId icons
>>= \icon -> return (iconClsAttr ("icon-"+++icon)))
instance tune ArrangeWithTabs
instance tune ArrangeWithTabs Task
where tune ArrangeWithTabs t = tune (ApplyLayout arrangeWithTabs) t
instance tune ArrangeWithSideBar
instance tune ArrangeWithSideBar Task
where
tune (ArrangeWithSideBar index side size resize) t = tune (ApplyLayout (arrangeWithSideBar index side size resize)) t
instance tune ArrangeSplit
instance tune ArrangeSplit Task
where
tune (ArrangeSplit direction resize) t = tune (ApplyLayout (arrangeSplit direction resize)) t
instance tune ArrangeVertical
instance tune ArrangeVertical Task
where
tune ArrangeVertical t = tune (ApplyLayout arrangeVertical) t
instance tune ArrangeHorizontal
instance tune ArrangeHorizontal Task
where
tune ArrangeHorizontal t = tune (ApplyLayout arrangeHorizontal) t
instance tune ToWindow
instance tune ToWindow Task
where
tune (ToWindow windowType vpos hpos) t = tune (ApplyLayout (toWindow windowType vpos hpos)) t
instance tune InPanel
instance tune InPanel Task
where
tune InPanel t = tune (ApplyLayout toPanel) t
instance tune InContainer
instance tune InContainer Task
where
tune InContainer t = tune (ApplyLayout toContainer) t
instance tune NoUserInterface
instance tune NoUserInterface Task
where
tune NoUserInterface (Task eval) = Task eval`
where
eval` event repOpts state iworld = eval event {repOpts & noUI = True} state iworld
instance tune Title
instance tune Title Task
where
tune (Title title) t = tune (ApplyLayout (setUIAttributes (titleAttr title)) ) t
instance tune Icon
instance tune Icon Task
where
tune (Icon icon) t = tune (ApplyLayout (setUIAttributes ('DM'.fromList [(ICON_ATTRIBUTE,JSONString icon)]))) t
instance tune Label
instance tune Label Task
where
tune (Label label) t = tune (ApplyLayout (setUIAttributes ('DM'.fromList [(LABEL_ATTRIBUTE,JSONString label)]))) t
definition module iTasks.UI.Tune
/**
* It is common to fine-tune the user interfaces of tasks.
* This module provides an overloaded way of annotating tasks or editors with attributes that
* change the behavior of the UI.
*/
from iTasks.WF.Definition import class iTask
from iTasks.WF.Definition import generic gEditor, generic gEq, generic gDefault, generic gText, generic JSONEncode, generic JSONDecode
from Data.Maybe import :: Maybe
from Text.JSON import :: JSONNode
from iTasks.UI.Editor import :: Editor
from iTasks.Internal.Generic.Visualization import :: TextFormat
class tune b f :: !b !(f a) -> f a
class tunev b a f | iTask a :: !(b a) !(f a) -> f a
/**
* Infix shorthands for the (overloaded) tune combinator.
*/
(<<@) infixl 2 :: !(f a) !b -> f a | tune b f
(@>>) infixr 2 :: !b !(f a) -> f a | tune b f
(<@@) infixl 2 :: !(f a) !(b a) -> f a | tunev b a f & iTask a
(@@>) infixr 2 :: !(b a) !(f a) -> f a | tunev b a f & iTask a
implementation module iTasks.UI.Tune
import iTasks.WF.Definition
class tune b f :: !b !(f a) -> f a
class tunev b a f | iTask a :: !(b a) !(f a) -> f a
(<<@) infixl 2 :: !(f a) !b -> f a | tune b f
(<<@) t a = tune a t
(@>>) infixr 2 :: !b !(f a) -> f a | tune b f
(@>>) a t = tune a t
(<@@) infixl 2 :: !(f a) !(b a) -> f a | tunev b a f & iTask a
(<@@) t a = tunev a t
(@@>) infixr 2 :: !(b a) !(f a) -> f a | tunev b a f & iTask a
(@@>) a t = tunev a t
......@@ -4,7 +4,7 @@ definition module iTasks.WF.Combinators.Common
*/
import iTasks.SDS.Definition
import iTasks.WF.Combinators.Core
import iTasks.WF.Combinators.Tune
import iTasks.UI.Tune
from Data.Map import :: Map
from Data.Either import :: Either
......@@ -102,13 +102,6 @@ tbind :: !(Task a) !(a -> Task b) -> Task b | iTask a & iTask b
*/
(@!) infixl 1 :: !(Task a) !b -> Task b
/**
* Infix shorthands for the (overloaded) tune combinator.
*/
(<<@) infixl 2 :: !(Task a) !b -> Task a | tune b
(@>>) infixr 2 :: !b !(Task a) -> Task a | tune b
(<@@) infixl 2 :: !(Task a) !(b a) -> Task a | tunev b a & iTask a
(@@>) infixr 2 :: !(b a) !(Task a) -> Task a | tunev b a & iTask a
/**
* 'Sidestep' combinator. This combinator has a similar signature as the core 'step'
* combinator, but instead of moving forward to a next step, the selected step is executed
* in parallel with the first task. When the chosen task step becomes stable, it is removed
......
......@@ -18,6 +18,7 @@ import iTasks.WF.Tasks.SDS
import iTasks.WF.Tasks.Interaction
import iTasks.WF.Combinators.Core, iTasks.WF.Combinators.Tune, iTasks.WF.Combinators.Overloaded
import iTasks.UI.Prompt
import iTasks.UI.Tune
import iTasks.UI.Layout
import iTasks.UI.Layout.Common, iTasks.UI.Layout.Default
......@@ -48,18 +49,6 @@ tbind taska taskbf = step taska (const Nothing) [OnAction ActionContinue (hasVal
(@!) infixl 1 :: !(Task a) !b -> Task b
(@!) task b = transform (fmap (const b)) task
(<<@) infixl 2 :: !(Task a) !b -> Task a | tune b
(<<@) t a = tune a t
(@>>) infixr 2 :: !b !(Task a) -> Task a | tune b
(@>>) a t = tune a t
(<@@) infixl 2 :: !(Task a) !(b a) -> Task a | tunev b a & iTask a
(<@@) t a = tunev a t
(@@>) infixr 2 :: !(b a) !(Task a) -> Task a | tunev b a & iTask a
(@@>) a t = tunev a t
try :: !(Task a) (e -> Task a) -> Task a | iTask a & iTask, toString e
try task handler = step task id [OnValue (ifStable return), OnException handler]
......
definition module iTasks.WF.Combinators.Tune
import iTasks.WF.Definition
from iTasks.UI.Tune import class tune(..)
from iTasks.UI.Layout import :: Layout
from Text.JSON import :: JSONNode
......@@ -8,20 +9,18 @@ from Text.JSON import :: JSONNode
* Fine tune a task by specifying custom layouts, tweaking generic layouts,
* or add additional titles, hints and descriptions
*/
class tune b :: !b !(Task a) -> Task a
class tunev b a | iTask a :: !(b a) !(Task a) -> Task a
//* Fine tune evaluation behaviour
:: LazyRefresh = LazyRefresh
instance tune LazyRefresh
instance tune LazyRefresh Task
//* Apply a layout to a task
:: ApplyLayout = ApplyLayout Layout
instance tune ApplyLayout
instance tune ApplyLayout Task
:: ApplyAttribute a = ApplyAttribute String a
class toAttribute a where toAttribute :: a -> JSONNode
instance toAttribute String
instance tune (ApplyAttribute a) | toAttribute a
instance tune (ApplyAttribute a) Task | toAttribute a
......@@ -2,6 +2,7 @@ implementation module iTasks.WF.Combinators.Tune
import iTasks.WF.Definition
import iTasks.UI.Definition
import iTasks.UI.Tune
import iTasks.UI.Layout
import iTasks.Internal.TaskState
......@@ -16,10 +17,7 @@ derive JSONDecode LayoutState, LayoutTree, MvUI, MvUIChild
/*
* Tuning of tasks
*/
class tune b :: !b !(Task a) -> Task a
class tunev b a | iTask a :: !(b a) !(Task a) -> Task a
instance tune LazyRefresh
instance tune LazyRefresh Task
where
tune _ (Task eval) = Task eval`
where
......@@ -28,7 +26,7 @@ where
(ValueResult value info rep tree,iworld) = (ValueResult value {TaskEvalInfo|info&refreshSensitive=False} rep tree, iworld)
(res,iworld) = (res,iworld)
instance tune ApplyLayout
instance tune ApplyLayout Task
where
tune (ApplyLayout l) task=:(Task evala) = Task eval
where
......@@ -64,7 +62,7 @@ where
class toAttribute a where toAttribute :: a -> JSONNode
instance toAttribute String where toAttribute s = JSONString s
instance tune (ApplyAttribute a) | toAttribute a
instance tune (ApplyAttribute a) Task | toAttribute a
where
tune (ApplyAttribute k v) task = tune (ApplyLayout (setUIAttributes ('DM'.fromList [(k,toAttribute v)]))) task
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment