CommonCombinators.icl 5.34 KB
Newer Older
1
implementation module CommonCombinators
2 3 4 5
/**
* This module contains a collection of handy iTasks combinators defined in terms of the basic iTask combinators
* with Thanks to Erik Zuurbier for suggesting some of the advanced combinators
*/
6
import StdBool, StdList, StdTuple, StdGeneric, StdMisc
7

8
from StdFunc	import id, const
9
from TSt		import :: Task(..), :: TaskDescription(..), :: TSt{..}, :: TaskInfo{..}, :: StaticInfo{..}, :: Workflow, :: ChangeLifeTime, :: Options, :: HTTPRequest, :: Config
Bas Lijnse's avatar
Bas Lijnse committed
10
from TSt		import applyTask, mkSequenceTask, mkParallelTask
Bas Lijnse's avatar
Bas Lijnse committed
11
from Types		import :: ProcessId, :: DynamicId, :: TaskId, :: TaskPriority(..), :: User(..)
12
from Store		import :: Store
Bas Lijnse's avatar
Bas Lijnse committed
13
from SessionDB	import :: Session
14
from TaskTree	import :: TaskTree
15
from CommonDomain	import :: Note
16

Bas Lijnse's avatar
Bas Lijnse committed
17
import SystemTasks, InteractionTasks, UserDBTasks, CoreCombinators, TuningCombinators, LiftingCombinators
18
import Util, Either
19
import GenVisualize, GenUpdate
20

21 22
derive gPrint Either
derive gParse Either
Bas Lijnse's avatar
Bas Lijnse committed
23

24 25
derive bimap	Maybe

26
//Task composition
27
(-||-) infixr 3 :: !(Task a) !(Task a) -> (Task a) | iTask a
28
(-||-) taska taskb  
29
=	parallel "-||-" (\list -> length list >= 1) (\[x:_] -> case x of (Left a) = a; (Right b) = b) (abort "-||- both parts finished??")
30 31
			[taska >>= \a -> return (Left a)
			,taskb >>= \b -> return (Right b)
32
			]
33
			
34
(-&&-) infixr 4 ::  !(Task a) !(Task b) -> (Task (a,b)) | iTask a & iTask b
35
(-&&-) taska taskb
36
=	parallel "-&&-" (\_ -> False) (abort "-&&- predicate became true??") (\[Left a, Right b] -> (a,b))
37 38
			[taska >>= \a -> return (Left a)
			,taskb >>= \b -> return (Right b)
39
			]
40

41
anyTask	:: ![Task a] -> Task a | iTask a
42
anyTask []		= getDefaultValue
43
anyTask tasks	= parallel "any" (\list -> length list >= 1) hd (abort "anyTask all parts finished??") tasks
44

45
allTasks :: ![Task a] -> Task [a] | iTask a
46
allTasks tasks = parallel "all" (\_ -> False) (abort "allTasks predicate became true") id tasks
Bas Lijnse's avatar
Bas Lijnse committed
47

48
eitherTask :: !(Task a) !(Task b) -> Task (Either a b) | iTask a & iTask b
49
eitherTask taska taskb 
50
=	parallel "eitherTask" (\list -> length list > 0) hd (abort "eitherTask all parts finished??")
51 52
			[ (taska >>= \a -> return (Left a)) <<@ "Left"
			, (taskb >>= \b -> return (Right b)) <<@ "Right"
53
			]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
54

55 56 57 58 59 60 61 62 63 64 65 66
(||-) infixr 3		:: !(Task a) !(Task b)						-> Task b				| iTask a & iTask b
(||-) taska taskb
	= parallel "||-" rightDone takeRight takeRight
		[ (taska >>= \a -> return (Left a)) <<@ "Left"
		, (taskb >>= \b -> return (Right b)) <<@ "Right"
		]
where
	rightDone [Right x] = True
	rightDone _			= False
	
	takeRight l			= hd [ x \\ (Right x) <- l] 

67 68 69 70 71 72 73 74 75 76 77
(-||) infixl 3		:: !(Task a) !(Task b)						-> Task a				| iTask a & iTask b
(-||) taska taskb
	= parallel "-||" leftDone takeLeft takeLeft
		[ (taska >>= \a -> return (Left a)) <<@ "Left"
		, (taskb >>= \b -> return (Right b)) <<@ "Right"
		]
where
	leftDone [Left x] 	= True
	leftDone _			= False
	
	takeLeft l			= hd [ x \\ (Left x) <- l] 
78

79
(>>?) infixl 1 	:: !(Task (Maybe a)) !(a -> Task (Maybe b)) -> Task (Maybe b) | iTask a & iTask b
80
(>>?) t1 t2 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
81
= 				t1 
82 83
	>>= \r1 -> 	case r1 of 
					Nothing 	-> return Nothing
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
84 85
					Just r`1 	-> t2 r`1

Bas Lijnse's avatar
Bas Lijnse committed
86 87 88 89 90
(-&?&-) infixr 4 :: !(Task (Maybe a)) !(Task (Maybe b)) -> Task (Maybe (a,b)) | iTask a & iTask b
(-&?&-) t1 t2 
= 	parallel "maybeTask" noNothing combineResult combineResult
			[(t1 >>= \tres -> return (Left tres)) <<@ "Left"
			,(t2 >>= \tres -> return (Right tres)) <<@ "Right"
91
			]
Bas Lijnse's avatar
Bas Lijnse committed
92 93 94 95 96 97 98 99 100
where
	noNothing []					= False
	noNothing [Left  Nothing:xs]	= True
	noNothing [Right Nothing:xs]	= True
	noNothing [x:xs]				= noNothing xs	

	combineResult	[Left (Just r1),Right (Just r2)]	= Just (r1,r2)
	combineResult	_									= Nothing

101 102 103 104 105 106 107 108 109 110
//Post processing of results
ignoreResult :: !(Task a) -> Task Void | iTask a
ignoreResult task = "ignoreResult" @>> (task >>| return Void)

transformResult :: !(a -> b) !(Task a) -> Task b | iTask a & iTask b
transformResult fun task = "transformResult" @>> (task >>= \a -> return (fun a))

stop :: Task Void
stop = "stop" @>> return Void

Bas Lijnse's avatar
Bas Lijnse committed
111

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
112 113 114
// ******************************************************************************************************
// repetition

115
repeatTask :: !(a -> Task a) !(a -> Bool) a -> Task a | iTask a
116 117
repeatTask task pred a =
	task a >>= \na -> if (pred na) (return na) (repeatTask task pred na)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
118

119
(<|) infixl 6 :: !(Task a) !(a -> (Bool, [HtmlTag])) -> Task a | iTask a
120 121 122
(<|) taska pred 
		=			taska
		>>= \r -> 	case pred r of
123
						(True,_) -> return r
124
						(False,msg) -> showStickyMessage msg ||- (taska <| pred)
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
125 126 127 128 129


// ******************************************************************************************************
// Assigning tasks to users, each user has to be identified by an unique number >= 0

130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145
instance @: UserId
where
	(@:) :: !UserId !(LabeledTask a) -> Task a | iTask a
	(@:) nuserId (label,task) = assign nuserId NormalPriority Nothing (task <<@ label)

instance @: User
where
	(@:) :: !User !(LabeledTask a) -> Task a | iTask a
	(@:) user task = user.User.userId @: task

instance @: String
where
	(@:) :: String !(LabeledTask a) -> Task a | iTask a
	(@:) name task
		 = getUserByName name
		 >>= \user -> user.User.userId @: task
146

Bas Lijnse's avatar
Bas Lijnse committed
147 148 149 150 151
assignByName :: !String !String !TaskPriority !(Maybe Timestamp) (Task a) -> Task a | iTask a
assignByName name subject priority deadline task
	=	getUserByName name
	>>= \user ->
		assign user.User.userId priority deadline (task <<@ subject)
152
// ******************************************************************************************************