implementation module CommonCombinators /** * This module contains a collection of useful iTasks combinators defined in terms of the basic iTask combinators */ import StdBool, StdList,StdOrdList, StdTuple, StdGeneric, StdMisc, StdInt, StdClass, GenRecord, Text, Time, Tuple, List import Util, Either, GenVisualize, GenUpdate from StdFunc import id, const, o from SystemTypes import :: User(..), :: Note(..) from TaskContext import :: TaskState(..), :: ParallelMeta, :: ParallelItem from SystemData import randomInt, topLevelTasks import CoreTasks, CoreCombinators, InteractionTasks, LayoutCombinators (>>*) infixl 1 :: !(Task a) ![TaskStep a b] -> Task b | iTask a & iTask b (>>*) task steps = step task steps (>>=) infixl 1 :: !(Task a) !(a -> Task b) -> Task b | iTask a & iTask b (>>=) taska taskbf = step taska [WithResult ActionContinue (const True) taskbf, WhenStable taskbf] (>>!) infixl 1 :: !(Task a) !(a -> Task b) -> Task b | iTask a & iTask b (>>!) taska taskbf = step taska [WithResult ActionContinue (const True) taskbf] (>>|) infixl 1 :: !(Task a) (Task b) -> Task b | iTask a & iTask b (>>|) taska taskb = step taska [WhenStable (const taskb)] (>>^) infixl 1 :: !(Task a) (Task b) -> Task a | iTask a & iTask b (>>^) taska taskb = taska >>= \x -> taskb >>| return x (@?) infixl 1 :: !(Task a) !((Maybe a) -> Maybe b) -> Task b | iTask a & iTask b (@?) task f = transform f task (@) infixl 1 :: !(Task a) !(a -> b) -> Task b | iTask a & iTask b (@) task f = transform (fmap f) task (@>) infixl 1 :: !(Task a) !((Maybe a) r -> Maybe w, ReadWriteShared r w) -> Task a | iTask a (@>) task (f,share) = project f share 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 try :: !(Task a) (e -> Task a) -> Task a | iTask a & iTask, toString e try task handler = step task [WhenStable return, Catch handler] catchAll :: !(Task a) (String -> Task a) -> Task a | iTask a catchAll task handler = step task [WhenStable return, CatchAll handler] //Helper functions for projections projectJust :: (Maybe a) r -> Maybe (Maybe a) projectJust mba _ = Just mba /* * When a task is assigned to a user a synchronous task instance process is created. * It is created once and loaded and evaluated on later runs. */ assign :: !ManagementMeta !(Task a) -> Task a | iTask a assign props task = parallel Void [(Embedded, \s -> processControl s),(Detached props, \_ -> task)] @? justResult where processControl tlist = (enterSharedChoice ("Waiting","Waiting for " <+++ task) [] (taskListMeta tlist)) @? const Nothing toView [_,{TaskListItem|progressMeta=Just p,managementMeta=Just m}]= { assignedTo = m.ManagementMeta.worker , priority = m.ManagementMeta.priority , issuedAt = Display (Just p.ProgressMeta.issuedAt) , issuedBy = Display (Just p.ProgressMeta.issuedBy) , firstWorkedOn = Display p.ProgressMeta.firstEvent , lastWorkedOn = Display p.ProgressMeta.latestEvent } toView [_,_]= { assignedTo = Nothing , priority = NormalPriority , issuedAt = Display Nothing , issuedBy = Display Nothing , firstWorkedOn = Display Nothing , lastWorkedOn = Display Nothing } fromView view=:{ProcessControlView|assignedTo} _ _ = []// [UpdateProperties 1 {mapRecord view & worker = assignedTo}] formatTimestamp timestamp = timestampToGmDateTime timestamp justResult (Just [_,Just a]) = Just a justResult _ = Nothing :: ProcessControlView = { assignedTo :: !Maybe User , priority :: !TaskPriority , issuedAt :: !Display (Maybe DateTime) , issuedBy :: !Display (Maybe User) , firstWorkedOn :: !Display (Maybe DateTime) , lastWorkedOn :: !Display (Maybe DateTime) } derive class iTask ProcessControlView derive class GenRecord ProcessControlView, ManagementMeta, TaskPriority (@:) infix 3 :: !User !(Task a) -> Task a | iTask a (@:) user task = assign {noMeta & worker = Just user} task justdo :: !(Task (Maybe a)) -> Task a | iTask a justdo task = task >>= \r -> case r of Just x = return x Nothing = throw ("The task returned nothing.") sequence :: !String ![Task a] -> Task [a] | iTask a sequence label tasks = Title label @>> (seqTasks tasks) where seqTasks [] = return [] seqTasks [t:ts] = t >>= \a -> seqTasks ts >>= \as -> return [a:as] //Repeat task until the predicate holds (loops if the predicate is false) ( .Bool) -> Task a | iTask a (>* [WhenStable (\a -> if (pred a) (return (Just a)) (restart (checked pred task) tlist))] res (Just [Just (Just a)]) = Just a res _ = Nothing restart task tlist = get (taskListMeta tlist) >>= \[{TaskListItem|taskId}:_] -> removeTask taskId tlist -&&- appendTask Embedded task tlist @ const Nothing forever :: !(Task a) -> Task a | iTask a forever t = (t (Task a) | iTask a (-||-) taska taskb = parallel Void [(Embedded, \_ -> taska),(Embedded, \_ -> taskb)] @? res where res (Just [Just a,_]) = Just a res (Just [Nothing,Just a]) = Just a res _ = Nothing (||-) infixr 3 :: !(Task a) !(Task b) -> Task b | iTask a & iTask b (||-) taska taskb = parallel Void [(Embedded, \_ -> taska @ Left),(Embedded, \_ -> taskb @ Right)] @? res where res (Just [_,Just (Right b)]) = Just b res _ = Nothing (-||) infixl 3 :: !(Task a) !(Task b) -> Task a | iTask a & iTask b (-||) taska taskb = parallel Void [(Embedded, \_ -> taska @ Left),(Embedded, \_ -> taskb @ Right)] @? res where res (Just [Just (Left a),_]) = Just a res _ = Nothing (-&&-) infixr 4 :: !(Task a) !(Task b) -> (Task (a,b)) | iTask a & iTask b (-&&-) taska taskb = parallel Void [(Embedded, \_ -> taska @ Left),(Embedded, \_ -> taskb @ Right)] @? res where res (Just [Just (Left a),Just (Right b)]) = Just (a,b) res _ = Nothing (>&>) infixl 1 :: (Task a) ((ReadOnlyShared (Maybe a)) -> Task b) -> Task b | iTask a & iTask b (>&>) taska taskbf = parallel Void [(Embedded, \s -> taska @ Left) ,(Embedded, \s -> taskbf (mapRead prj (toReadOnly (taskListState s))) @ Right) ] @? res where prj [Just (Left a),_] = Just a prj _ = Nothing res (Just [_,Just (Right b)]) = Just b res _ = Nothing :: ProcessOverviewView = { index :: !Hidden Int , subject :: !Display String , assignedTo :: !User } derive class iTask ProcessOverviewView anyTask :: ![Task a] -> Task a | iTask a anyTask tasks = parallel Void [(Embedded,const t) \\ t <- tasks] @? res where res (Just ([Just a:_])) = Just a res (Just ([Nothing:as])) = res (Just as) res _ = Nothing allTasks :: ![Task a] -> Task [a] | iTask a allTasks tasks = parallel Void [(Embedded,const t) \\ t <- tasks] @? res where res (Just []) = Just [] res (Just [Just a:mbas]) = case res (Just mbas) of Just as = Just [a:as] Nothing = Nothing res _ = Nothing eitherTask :: !(Task a) !(Task b) -> Task (Either a b) | iTask a & iTask b eitherTask taska taskb = parallel Void [(Embedded, \s -> (taska @ Left)) ,(Embedded, \s -> (taskb @ Right)) ] @? res where res (Just [Just la,_]) = Just la res (Just [_,Just rb]) = Just rb res _ = Nothing randomChoice :: ![a] -> Task a | iTask a randomChoice [] = throw "Cannot make a choice from an empty list" randomChoice list = get randomInt >>= \i -> return (list !! ((abs i) rem (length list))) repeatTask :: !(a -> Task a) !(a -> Bool) a -> Task a | iTask a repeatTask task pred a = task a >>= \na -> if (pred na) (return na) (repeatTask task pred na) whileUnchanged :: !(ReadWriteShared r w) (r -> Task b) -> Task b | iTask r & iTask w & iTask b whileUnchanged share task = (( get share >>= \val -> (task val @ Just) -||- (wait "watching share change" ((=!=) val) share >>| return Nothing) ) Task TaskId | iTask a appendTopLevelTask props task = appendTask (Detached props) (\_ -> task @ const Void) topLevelTasks @ \topNo -> (TaskId topNo 0) appendTopLevelTaskFor :: !User !(Task a) -> Task TaskId | iTask a appendTopLevelTaskFor user task = appendTopLevelTask {noMeta & worker = Just user} task instance tune BeforeLayout where tune (BeforeLayout f) task = tune (ModifyLayout (\l t0 pa0 ac0 at0 -> let (t1,pa1,ac1,at1) = f (t0,pa0,ac0,at0) in l t1 pa1 ac1 at1)) task instance tune AfterLayout where tune (AfterLayout f) task = tune (ModifyLayout (\l -> (\t pa ac at -> (f (l t pa ac at))))) task instance tune Title where tune (Title title) task = tune (BeforeLayout (\(t,pa,ac,at) -> (t,pa,ac,kvSet TITLE_ATTRIBUTE title at))) task instance tune Icon where tune (Icon icon) task = tune (BeforeLayout (\(t,pa,ac,at) -> (t,pa,ac,kvSet ICON_ATTRIBUTE icon at))) task instance tune Attribute where tune (Attribute k v) task = tune (BeforeLayout (\(t,pa,ac,at) -> (t,pa,ac,kvSet k v at))) task instance tune Window where tune Window task = task