iTasks2.icl 6.43 KB
Newer Older
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
1 2 3 4 5 6 7 8 9 10
implementation module iTasks2

// (c) iTask & iData Concept and Implementation by Rinus Plasmeijer, 2006-2008 - MJP

// Definition of non-primitive iTask combinators defined in terms of primitive iTask combinators  

import StdEnv
import iTasks
import iDataTrivial

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
11 12 13 14 15 16
derive gForm 	[]
derive gUpd  	[]
derive gUpd 	Maybe
derive gForm 	Maybe
derive gPrint 	Maybe
derive gParse 	Maybe
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
17 18 19 20 21 22 23 24 25

// ******************************************************************************************************
// monads for combining iTasks

(#>>) infixl 1 :: !(Task a) !(Task b) -> Task b | iCreateAndPrint b
(#>>) taska taskb 
=				taska
	=>> \_ ->	taskb 

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
26 27 28 29 30 31
(=>>?) infixl 1 	:: !(Task (Maybe a)) !(a -> Task (Maybe b)) -> Task (Maybe b) | iCreateAndPrint a & iCreateAndPrint b
(=>>?) t1 t2 
= 				t1 
	=>> \r1 -> 	case r1 of 
					Nothing 	-> return_V Nothing
					Just r`1 	-> t2 r`1
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
32 33 34 35 36 37
return_VF :: !HtmlCode !a -> (Task a) | iCreateAndPrint a
return_VF bodytag a = return_V a <<! bodytag

return_D :: !a -> (Task a) | gForm {|*|}, iCreateAndPrint a
return_D a = return_V a <<! [toHtml a ]

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
38 39 40 41 42 43 44 45 46 47 48 49 50 51
// ******************************************************************************************************
// repetition

repeatTask :: !(a -> Task a) !(a -> Bool) a -> Task a | iData a
repeatTask task pred a = dorepeatTask a
where
	dorepeatTask a 
	= newTask "doReapeatTask" dorepeatTask`
	where
		dorepeatTask` tst
		| pred a	= (a,tst) 
		# (na,tst)	= task a tst	
		= dorepeatTask na tst

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
52 53 54 55 56 57 58 59 60 61
(<|) infixl 6 :: !(Task a) !(a -> (Bool, HtmlCode)) -> Task a | iData a
(<|) taska pred = mkTask "repeatTest" doTask
where
	doTask
	=				taska
		=>> \r -> 		case pred r of
						(True,_) -> return_V r
						(False,msg) -> msg ?>> doTask


Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
62 63 64
// ******************************************************************************************************
// Assigning tasks to users, each user has to be identified by an unique number >= 0

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
65
(@:) infix 3 :: !UserId !(LabeledTask a) -> Task a | iData a
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
66 67
(@:) nuserId ltask = assignTaskTo True nuserId ltask

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
68
(@::) infix 3 :: !UserId !(Task a)	-> (Task a) | iData  a												
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
69 70
(@::) nuserId taska = assignTaskTo True nuserId ("Task for " <+++ nuserId,taska)

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
71
(@:>) infix 3 :: !UserId !(LabeledTask a) -> Task a | iData a
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
72 73
(@:>) nuserId ltask = assignTaskTo False nuserId ltask

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
74
(@::>) infix 3 :: !UserId !(Task a) -> (Task a) | iData  a												
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
75 76 77 78 79
(@::>) nuserId taska = assignTaskTo False nuserId ("Task for " <+++ nuserId,taska)

// ******************************************************************************************************
// choose one or more tasks on forehand out of a set

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
80 81 82
button :: !String !a -> (Task a) | iCreateAndPrint a
button s a = mkTask "button" (chooseTask_btn [] True [(s,return_V a)])

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
83 84 85 86 87 88 89 90 91 92 93
buttonTask :: !String !(Task a) -> (Task a) | iCreateAndPrint a
buttonTask s task = mkTask "buttonTask" (chooseTask_btn [] True [(s,task)])

chooseTask :: !HtmlCode ![LabeledTask a] -> (Task a) | iCreateAndPrint a
chooseTask prompt options = mkTask "chooseTask" (chooseTask_btn prompt True options)

chooseTaskV :: !HtmlCode ![LabeledTask a] -> (Task a) | iCreateAndPrint a
chooseTaskV prompt options = mkTask "chooseTask" (chooseTask_btn prompt False options)

mchoiceTasks :: !HtmlCode ![LabeledTask a] -> (Task [a]) | iData a
mchoiceTasks prompt taskOptions 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
94
= chooseTask_cbox seqTasks prompt [((False,\b bs -> bs,[]),labeltask) \\ labeltask <- taskOptions]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
95 96 97

mchoiceTasks2 :: !HtmlCode ![(!Bool,LabeledTask a)] -> Task [a] | iData a
mchoiceTasks2 prompt taskOptions 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
98
= chooseTask_cbox seqTasks prompt [((set,\b bs -> bs,[]),labeltask) \\ (set,labeltask) <- taskOptions]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
99 100 101

mchoiceTasks3 :: !HtmlCode ![((!Bool,!ChoiceUpdate,!HtmlCode),LabeledTask a)] -> Task [a] | iData a
mchoiceTasks3 prompt taskOptions 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
102
= chooseTask_cbox seqTasks prompt taskOptions
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
103 104 105

mchoiceAndTasks :: !HtmlCode ![LabeledTask a] -> (Task [a]) | iData a
mchoiceAndTasks prompt taskOptions 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
106
= chooseTask_cbox andTasks prompt [((False,\b bs -> bs,[]),labeltask) \\ labeltask <- taskOptions]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
107 108 109

mchoiceAndTasks2 :: !HtmlCode ![(!Bool,LabeledTask a)] -> Task [a] | iData a
mchoiceAndTasks2 prompt taskOptions 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
110
= chooseTask_cbox andTasks prompt [((set,\b bs -> bs,[]),labeltask) \\ (set,labeltask) <- taskOptions]
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
111 112 113

mchoiceAndTasks3 :: !HtmlCode ![((!Bool,!ChoiceUpdate,!HtmlCode),LabeledTask a)] -> Task [a] | iData a
mchoiceAndTasks3 prompt taskOptions 
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
114
= chooseTask_cbox andTasks prompt taskOptions
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139

// ******************************************************************************************************
// Speculative OR-tasks: task ends as soon as one of its subtasks completes

(-||-) infixr 3 :: !(Task a) !(Task a) -> (Task a) | iData a
(-||-) taska taskb =  newTask "-||-" (doOrTask (taska,taskb))
where
	doOrTask :: !(Task a,Task a) -> (Task a) | iCreateAndPrint a
	doOrTask (taska,taskb)
	= 			orTask2 (taska,taskb)
		=>> \at ->  case at of
						(LEFT a)  -> return_V a
						(RIGHT b) -> return_V b

(-&&-) infixr 4 ::  !(Task a) !(Task b) -> (Task (a,b)) | iData a & iData b
(-&&-) taska taskb = newTask "-&&-" (andTask2 (taska,taskb))

orTasks :: ![LabeledTask a] -> (Task a) | iData a
orTasks []				= return createDefault
orTasks taskCollection	= newTask "orTasks" (andTasksCond "or Tasks" (\list -> length list >= 1) taskCollection)
							=>> \list -> return  (hd list)

andTasks :: ![LabeledTask a] -> (Task [a]) | iData a
andTasks taskCollection = newTask "andTasks" (andTasksCond "and Tasks" (\_ -> False) taskCollection)

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
140 141 142 143 144 145 146 147 148 149 150
(-&&-?) infixr 4 :: !(Task (Maybe a)) !(Task (Maybe b)) -> Task (Maybe (a,b)) | iData a & iData b
(-&&-?) t1 t2 
= 		andTasksCond "Maybe Task" noNothing [("Maybe 1",left),("Maybe 2",right)]
  =>>	combineResult
where
	left 	= t1 =>> \tres -> return_V (LEFT tres) 
	right	= t2 =>> \tres -> return_V (RIGHT tres) 

	combineResult	[LEFT (Just r1),RIGHT (Just r2)]	= return_V (Just (r1,r2))
	combineResult	_									= return_V Nothing

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
151
	noNothing []					= False
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
152 153
	noNothing [LEFT  Nothing:xs]	= True
	noNothing [RIGHT Nothing:xs]	= True
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
154
	noNothing [x:xs]				= noNothing xs	
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
155

Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
156 157 158 159 160 161 162 163 164 165 166 167
andTasks_mu :: !String ![(Int,Task a)] -> (Task [a]) | iData a
andTasks_mu label tasks = newTask "andTasks_mu" (domu_andTasks tasks)
where
	domu_andTasks list = andTasks [(label  <+++ " " <+++ i, i @:: task) \\ (i,task) <- list] 

// ******************************************************************************************************
// Timer Tasks ending when timed out

waitForTimerTask:: !HtmlTime	-> (Task HtmlTime)
waitForTimerTask time  = waitForTimerTask`
where
	waitForTimerTask`
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
168
	=						appHStOnce "getTimeAndDate" getTimeAndDate
Rinus Plasmeijer's avatar
Rinus Plasmeijer committed
169 170
		=>> \(ctime,_) ->  	waitForTimeTask (ctime + time)