stepparallel/test.icl

   1 module test
   2
   3 import StdMisc
   4 import iTasks
   5 import Data.Either
   6 import StdEnv
   7 import Data.Func
   8 import Data.Functor
   9
  10 Start w = flip doTasks w $
  11         updateInformation () [] 42
  12         >>* [OnAction (Action "Continue") (always (return 43))]
  13
  14 (>>*) infixl 1// :: !(Task a) ![TaskCont a (Task b)] -> Task b | iTask a & iTask b
  15 (>>*) task steps :== step task (const Nothing) steps
  16
  17 step :: !(Task a) ((Maybe a) -> Maybe b) [TaskCont a (Task b)] -> Task b | iTask a & iTask b
  18 step lhs lhsValFun conts
  19         = parallel
  20                 [(Embedded, \stl->lhs @? \v->case v of
  21                         NoValue = Value (Left Nothing) False
  22                         (Value v s) = Value (Left (Just v)) s
  23                 )]
  24                 (map stepCont conts)
  25                 @? stepVal lhsValFun
  26 where
  27         stepVal :: ((Maybe a) -> Maybe b) (TaskValue [(Int, TaskValue (Either (Maybe a) b))]) -> TaskValue b
  28         stepVal tfun NoValue = NoValue
  29         stepVal tfun (Value [(_, x):_] _) = case x of
  30                 //Not yet stepped:
  31                 Value (Left l) s = case tfun l of
  32                         Nothing = NoValue
  33                         Just v = Value v False
  34                 //Stepped but no value
  35                 NoValue = NoValue
  36                 Value (Right r) s = Value r s
  37         stepVal _ _ = abort "cannot happen"
  38
  39         stepCont (OnValue f) = OnValue (transform f)
  40         stepCont (OnAction a f) = OnAction a (transform f)
  41         stepCont (OnException f) = OnException \e->add (f e)
  42         stepCont (OnAllExceptions f) = OnAllExceptions \e->add (f e)
  43
  44         transform f v
  45                 # v = case v of
  46                         Value [(_, v)] _ = case v of
  47                                 NoValue = NoValue
  48                                 Value (Left (Just v)) s = Value v s
  49                                 Value _ _ = NoValue
  50                         NoValue = NoValue
  51                 = add <$> f v
  52
  53         add t = (Embedded, \stl->
  54                 get (sdsFocus {onlyIndex=Nothing,onlyTaskId=Nothing,onlySelf=False,includeValue=False,includeProgress=False,includeAttributes=False} stl)
  55                 >>- \(_, pts)->case pts of
  56                         [tli:_] = removeTask tli.TaskListItem.taskId stl
  57                                 >-| t @ Right
  58                         _ = abort "shouldn't happen"
  59                 )
  60