implementation module FlowData import iTasks, TaskContainer from FormFlowStorage import findValue, findFlow derive gPrint Flow, FlowShape, AssignInfo, CleanExpr derive gParse Flow, FlowShape, AssignInfo, CleanExpr derive gUpdate Flow, FlowShape, AssignInfo, CleanExpr derive gVisualize Flow, FlowShape, AssignInfo, CleanExpr derive bimap Maybe, (,) :: Flow = { flowShape :: ![FlowShape] , flowDyn :: !Dynamic } :: FlowShape = Editor !String | DisplayIt !String | Return | Assign !AssignInfo ![FlowShape] | Or !([FlowShape], ![FlowShape]) | And !([FlowShape], ![FlowShape]) | FormFromStore !String | FlowFromStore !String | CleanExpr !CleanExpr | First | Second :: AssignInfo = { nameOfUser:: !String , taskName :: !String } :: CleanExpr = CI Int | CR Real | CB Bool | CS String | VoidVal | CE String emptyFlow :: Flow emptyFlow = { flowShape = [] , flowDyn = dynamic "Flow not initialized" :: String } flowShapeToFlow :: ![FlowShape] -> Task Flow flowShapeToFlow flowShape = flowShapeToFlowDyn flowShape >>= \flowDyn -> if (validType flowDyn) (return {flowShape = flowShape, flowDyn = flowDyn}) (throw (typeErrorMess "not a legal workflow, " flowDyn)) >>| return {flowShape = flowShape, flowDyn = flowDyn} validType :: Dynamic -> Bool validType (T x :: T (Task a) a) = True validType (T x :: T (a -> Task a) a) = True validType (T x :: T (a -> Task b) b) = True validType (f :: A.a: a -> Task a | iTask a) = True validType (f :: A.a: a -> Task (t a) | iTask a) = True validType (f :: A.a: a -> Task (t a a) | iTask a) = True validType (f :: A.a b: a -> Task (t a b) | iTask a & iTask b ) = True validType (f :: A.a: a -> Task (t a a a) | iTask a) = True validType (f :: A.a b c: a -> Task (t a b c) | iTask a & iTask b & iTask c) = True validType (f :: A.a: a -> Task Void) = True validType (f :: A.a: a -> Task Int) = True validType (f :: A.a: a -> Task Real) = True validType (f :: A.a: a -> Task Bool) = True validType (f :: A.a: a -> Task String) = True validType (f :: A.a: (Task a) -> Task a | iTask a) = True validType d = False flowShapeToFlowDyn :: ![FlowShape] -> Task Dynamic flowShapeToFlowDyn [] = throw ("Flow list has to contain at least one element.") flowShapeToFlowDyn flows = mapMonad translate flows >>= \[d:ds] -> return (applyFlows d ds) where mapMonad :: (!FlowShape -> Task Dynamic) [FlowShape] -> Task [Dynamic] // leaving out the type crashes the compiler !!! mapMonad fun [] = return [] mapMonad fun [d:ds] = fun d >>= \nd -> mapMonad fun ds >>= \nds -> return [nd:nds] translate :: !FlowShape -> Task Dynamic translate (Editor prompt) = return (dynamic (edit prompt):: A.a: a -> Task a | iTask a) where edit :: !String a -> Task a | iTask a edit prompt v = updateInformation prompt v translate (DisplayIt prompt) = return (dynamic (display prompt):: A.a: a -> Task Void | iTask a) where display :: !String a -> Task Void | iTask a display prompt v = showMessageAbout prompt v translate Return = return (dynamic (\v -> return v) :: A.a: a -> Task a | iTask a) translate (Or (left, right)) = flowShapeToFlowDyn left >>= \leftflow -> flowShapeToFlowDyn right >>= \rightflow -> checkOr leftflow rightflow where checkOr :: Dynamic Dynamic -> Task Dynamic checkOr (T ta :: T (Task a) a) (T tb :: T (Task a) a) = return (dynamic T (ta -||- tb) :: T (Task a) a) checkOr (T ta :: T (a -> Task a) a) (T tb :: T (a -> Task a) a) = return (dynamic T (\a -> ta a -||- tb a) :: T (a -> Task a) a) checkOr (ta :: A.a: a -> Task a | iTask a) (tb :: A.a: a -> Task a | iTask a) = return (dynamic (\a -> ta a -||- tb a) :: A.a: a -> Task a | iTask a) checkOr d1 d2 = throw (typeErrorMess2 "Or" d1 d2) translate (And (left, right)) = flowShapeToFlowDyn left >>= \leftflow -> flowShapeToFlowDyn right >>= \rightflow -> checkAnd leftflow rightflow where checkAnd :: Dynamic Dynamic -> Task Dynamic checkAnd (T ta :: T (Task a) a) (T tb :: T (Task b) b) = return (dynamic T (ta -&&- tb) :: T (Task (a,b)) (a,b)) checkAnd (T ta :: T (a -> Task b) b) (T tb :: T (a -> Task c) c) = return (dynamic T (\a -> ta a -&&- tb a) :: T (a -> Task (b,c)) (b,c)) checkAnd (ta :: A.a: a -> Task a | iTask a) (tb :: A.a: a -> Task a | iTask a) = return (dynamic (\a -> ta a -&&- tb a) :: A.a: a -> Task (a,a) | iTask a ) checkAnd d1 d2 = throw (typeErrorMess2 "And" d1 d2) translate (Assign info []) = return (dynamic (\t -> assign info.nameOfUser NormalPriority Nothing (t <<@ info.taskName)) :: A.a: (Task a) -> Task a | iTask a) translate (Assign info flow) = flowShapeToFlowDyn flow >>= assignTask info where assignTask :: !AssignInfo !Dynamic -> Task Dynamic assignTask info (e :: A.a: a -> Task a | iTask a) = return (dynamic (apply info e) :: A.a: a -> Task a | iTask a) where apply :: !AssignInfo !(A.a: a -> Task a | iTask a) b -> Task b | iTask b apply info e v = assign info.nameOfUser NormalPriority Nothing (e v <<@ info.taskName) assignTask info d = throw (typeErrorMess "Assign" d) translate First = return (dynamic fst :: A.a b: (a,b) -> a) translate Second = return (dynamic snd :: A.a b: (a,b) -> b) translate (FormFromStore name) = findValue name translate (FlowFromStore name) = findFlow name translate (CleanExpr (CI i)) = return (dynamic T (return i) :: T (Task Int) Int) translate (CleanExpr (CR r)) = return (dynamic T (return r) :: T (Task Real) Real) translate (CleanExpr (CB b)) = return (dynamic T (return b) :: T (Task Bool) Bool) translate (CleanExpr (CS s)) = return (dynamic T (return s) :: T (Task String) String) translate (CleanExpr VoidVal ) = return (dynamic T (return Void) :: T (Task Void) Void) translate (CleanExpr (CE s)) = interpret s applyDynFlows :: ![Dynamic] -> Dynamic applyDynFlows [] = dynamic "Cannot apply empty list of flows" applyDynFlows [h:tl] = applyFlows h tl applyFlows :: Dynamic [Dynamic] -> Dynamic applyFlows dyn [] = dyn applyFlows (T t :: T (Task a) a) [(btb :: A.b: b -> Task b | iTask b ): dyns] = applyFlows (dynamic T (t >>= btb) :: T (Task a) a) dyns applyFlows (T t :: T (Task a) a) [(T btb :: T (a -> Task b) b ): dyns] = applyFlows (dynamic T (t >>= btb) :: T (Task b) b) dyns applyFlows (T t :: T (Task a) a) [(btb :: A.b: b -> Task Void | iTask b ): dyns] = applyFlows (dynamic T (t >>= btb) :: T (Task Void) Void) dyns applyFlows (T ta :: T (Task a) a) [(T tb :: T (Task b) b): dyns] = applyFlows (dynamic T (ta >>| tb) :: T (Task b) b) dyns applyFlows (ta :: A.a: a -> Task a | iTask a) [(tb:: A.b: b -> Task b | iTask b): dyns] = applyFlows (dynamic \a -> ta a >>= tb :: A.a: a -> Task a | iTask a) dyns //applyFlows (ta :: A.a: a -> Task a | iTask a) [(tb:: A.b: b -> Task Void): dyns] // gives crash in compiler ???? // = applyFlows (dynamic \a -> ta a >>= tb :: A.a: a -> Task Void | iTask a) dyns applyFlows (tt :: A.a: (Task a) -> Task a | iTask a) [(T ta :: T (Task a) a): dyns] = applyFlows (dynamic T (tt ta) :: T (Task a) a) dyns applyFlows (x :: a) [(f :: a -> b): dyns] // common dyn apply = applyFlows (dynamic f x :: b) dyns applyFlows d [d1:_] = dynamic (typeErrorMess2 "Cannot apply" d d1) // ****************** interpret s = return (dynamic "Not implemented")