TaskPatterns.icl 10.8 KB
Newer Older
1 2
implementation module Incidone.Util.TaskPatterns

3
import iTasks, iTasks.Extensions.Dashboard
4
import iTasks.UI.Definition
5
import Incidone.OP.IncidentManagementTasks, Incidone.OP.ContactManagementTasks
Bas Lijnse's avatar
Bas Lijnse committed
6
import Text, Data.Functor, Data.Either, Data.Maybe
7
import qualified Data.Map as DM
8
import Data.Map.GenJSON
9
import StdMisc
10

11 12
//FIXME
/*
13 14 15 16 17
fillNotes :: [(UIControl,UIAttributes)] -> [(UIControl,UIAttributes)]
fillNotes cs = map fillNote cs
where
    fillNote (c=:(UIEditNote _ _),a) = (fillHeight c,'DM'.newMap)
    fillNote x = x
18
*/
19 20 21 22 23 24 25 26

/**
* Create a new incident containing no information at all.
*/
createNewIncident :: Task (Maybe IncidentNo)
createNewIncident
	=	enterInformation ("Create new incident", "Fill in the following basic information to create a new incident") []
	>>? createIncident
27

28 29 30 31 32
createNewContact :: Task (Maybe ContactNo)
createNewContact
	=	enterInformation ("New contact","Enter the basic information of the new contact") []
	>>? createContact

33 34
indexedStore :: String v -> SDSLens k v v | Eq k & Ord k & iTask k & iTask v
indexedStore name def = sdsSplit "indexedStore" (\p -> ((),p)) read write (Just \p mapping. Ok (fromMaybe def ('DM'.get p mapping))) (sharedStore name 'DM'.newMap)
35 36
where
    read p mapping = fromMaybe def ('DM'.get p mapping)
37
    write p mapping v = ('DM'.put p v mapping,const ((==) p))
38

39
sdsDeref :: (sds1 p [a] [a]) (a -> Int) (sds2 [Int] [b] x) ([a] [b] -> [c]) -> (SDSSequence p [c] [a]) | iTask p & TC a & TC b & TC c & TC x & RWShared sds1 & RWShared sds2
Bas Lijnse's avatar
Bas Lijnse committed
40
sdsDeref sds1 toRef sds2 merge = sdsSequence "sdsDeref" paraml paramr (\_ _ -> Right read) writel writer sds1 sds2
41
where
Bas Lijnse's avatar
Bas Lijnse committed
42 43
	paraml p = p
	paramr p r1 = map toRef r1
44 45
    param _ r = (\_ r -> map toRef r)
    read (as,bs) = merge as bs
Bas Lijnse's avatar
Bas Lijnse committed
46

47 48 49
    writel = SDSWriteConst (\_ w -> Ok (Just w))
    writer = SDSWriteConst (\_ _ -> Ok Nothing)

50
viewDetails	:: !d (sds1 () (Maybe i) ()) (sds2 i c c) (c -> v) -> Task (Maybe v) | toPrompt d & iTask i & iTask v & iTask c & RWShared sds1 & RWShared sds2
Bas Lijnse's avatar
Bas Lijnse committed
51
viewDetails desc sel target prj = viewSharedInformation desc [] (mapRead (fmap prj) (targetShare sel target))
52
where
53
	targetShare :: (sds1 () (Maybe i) ()) (sds2 i c c) -> SDSSequence () (Maybe c) () | iTask i & iTask c & RWShared sds1 & RWShared sds2
Bas Lijnse's avatar
Bas Lijnse committed
54
    targetShare sel target = sdsSequence "viewDetailsSeq" id (\_ i -> i) (\_ _ -> Right snd) writel writer sel (valueShare target)
55 56 57 58
    where
        writel = SDSWriteConst (\_ _ -> Ok Nothing)
        writer = SDSWriteConst (\_ _ -> Ok Nothing)

59 60 61 62 63 64
    valueShare :: (sds1 i c c) -> SDSSelect (Maybe i) (Maybe c) () | iTask i & iTask c & RWShared sds1
    valueShare target = sdsSelect "viewDetailsValue" param 
        (SDSNotifyConst (\_ _ _ _-> False)) 
        (SDSNotifyConst (\_ _ _ _-> False))
		(constShare Nothing) 
        (mapRead Just (toReadOnly target))
Bas Lijnse's avatar
Bas Lijnse committed
65 66 67
	where
    	param Nothing = Left ()
    	param (Just i) = Right i
68

69
optionalNewOrOpen   :: (String,Task ()) (String,i -> Task ()) Workspace (sds () (Maybe i) ()) -> Task () | iTask i & RWShared sds
70 71 72
optionalNewOrOpen (newLabel,newTask) (openLabel,openTask) ws selection
	= forever (
		watch selection >>*
Bas Lijnse's avatar
Bas Lijnse committed
73 74
			[OnAction (Action newLabel) (always (addToWorkspace (newTask <<@ InWindow) ws))
			,OnAction (Action openLabel) (ifValue isJust (\(Just c) -> addToWorkspace (doOrClose (openTask c)) ws))
75 76 77
			]
	)

78
doAddRemoveOpen     :: (Task a) (r -> Task b) (r -> Task c) Workspace (sds () (Maybe r) w) -> Task () | iTask a & iTask b & iTask c & iTask r & RWShared sds & TC w
79 80
doAddRemoveOpen  add remove open ws selection = forever
	(watch selection >>*
Bas Lijnse's avatar
Bas Lijnse committed
81 82 83
		[OnAction (Action "/Add")	  (always (addToWorkspace add ws))
		,OnAction (Action "/Remove")  (ifValue isJust	(\(Just sel) -> addToWorkspace (remove sel) ws))
		,OnAction (Action "/Open")    (ifValue isJust	(\(Just sel) -> addToWorkspace (open sel) ws))
84 85 86 87 88 89
		]
	)

//Move to util
viewAndEdit :: (Task a) (Task b) -> Task b | iTask a & iTask b
viewAndEdit view edit
Bas Lijnse's avatar
Bas Lijnse committed
90
    = forever (view >>* [OnAction (Action "Edit") (always edit)])
91 92

//Move to common tasks
93
viewOrEdit :: d (Shared sds a) (a a -> Task ()) -> Task () | toPrompt d & iTask a & RWShared sds
94
viewOrEdit prompt s log
Bas Lijnse's avatar
Bas Lijnse committed
95
	= forever (view >>* [OnAction (Action "/Edit") (hasValue edit)]) @! ()
96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
where
	view = viewSharedInformation prompt [] s
	edit old
		=	updateInformation prompt [] old
		>>?	\new ->
			set new s
        >>| log old new

doOrClose :: (Task a) -> Task (Maybe a) | iTask a
doOrClose task = ((task @ Just) -||- chooseAction [(ActionClose,Nothing)]) >>- return

doOrCancel :: (Task a) -> Task (Maybe a) | iTask a
doOrCancel task = (chooseAction [(ActionCancel,Nothing)] -||- (task @ Just)) >>- return

//withHeader :: (Task a) (Task b) -> Task b | iTask a	& iTask b
//withHeader headerTask bodyTask
//	= ((headerTask <<@ ForceLayout) ||- (bodyTask <<@ ForceLayout)) <<@ (ArrangeWithSideBar 0 TopSide 50 False)

withHeader :: (Task a) (Task b) -> Task b | iTask a	& iTask b
withHeader headerTask bodyTask
116 117 118
	= (headerTask ||- bodyTask ) //<<@ AfterLayout arrange
//FIXME
/*
119
where
120

121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
    arrange ui=:{UIDef|content=UIBlocks [header,body] actions,windows}
        # (hcontrol,_,_,_) = blockToControl header
        # (UIContainer sOpts iOpts=:{UIItemsOpts|items},_,_,_) = blockToContainer body
        # bcontrol = case items of
            [item]  = UIContainer sOpts {UIItemsOpts|iOpts & items = [setHeight FlexSize item]}
            _       = UIContainer sOpts iOpts
        = {UIDef|content= UIBlock
            {UIBlock
            |attributes = header.UIBlock.attributes
            ,content = defaultItemsOpts [hcontrol,setHeight FlexSize bcontrol]
            ,actions = actions
            ,hotkeys = header.UIBlock.hotkeys ++ body.UIBlock.hotkeys
            ,size = defaultSizeOpts
            },windows = windows}
    arrange ui = ui
136
*/
137 138 139 140 141 142 143 144 145 146 147

viewNoSelection :: Task ()
viewNoSelection = viewTitle "Select..." @! ()

(>>?) infixl 1 :: !(Task a) !(a -> Task b) -> Task (Maybe b) | iTask a & iTask b
(>>?) taska taskbf = step taska (const Nothing)
                            [OnAction ActionCancel			(always (return Nothing))
							,OnAction ActionOk              (hasValue (\a -> taskbf a @ Just))
							,OnValue  					    (ifStable (\a -> taskbf a @ Just))
							]

148
oneOrAnother :: !d (String,Task a) (String,Task b) -> Task (Either a b) | toPrompt d & iTask a & iTask b
149
oneOrAnother desc (labela,taska) (labelb,taskb)
150
    =   updateChoice desc [ChooseFromCheckGroup ((!!) [labela,labelb])]  [0,1] 0  <<@ ApplyLayout (setUIAttributes (heightAttr WrapSize))
151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167
    >&> \s -> whileUnchanged s (
        \choice -> case choice of
            Nothing = (viewInformation () [] "You have to make a choice" @? const NoValue)
            (Just 0) = (taska @ Left)
            (Just 1) = (taskb @ Right)
        )

enterMultiple :: !String !Int (Task a) -> Task [a] | iTask a
enterMultiple action min task
    =   parallel ([(Embedded, const t) \\ t <- repeatn min task] ++ [(Embedded,more)]) [] @? res
where
    res (Value l _) = Value [v \\ (_,Value v _) <- l] (foldl allStable True l)

    allStable cur (_,Value _ s) = cur && s
    allStable cur _             = False

    more list =   viewInformation () [] ()
Bas Lijnse's avatar
Bas Lijnse committed
168
              >>* [OnAction (Action action) (always (appendTask Embedded more list >>| task))]
169

170
manageSharedListWithDetails :: (Int -> Task ()) (Task Int) (Shared sds [Int]) -> Task () | RWShared sds
171 172 173
manageSharedListWithDetails detailsTask addTask refsList //Not the best implementation, but good enough for now
    =   get refsList
    >>- \initList ->
174
        parallel ([(Embedded, removeWhenStable (detailsTask i)) \\ i <- initList] ++ [(Embedded,add)]) []
175 176 177 178 179 180 181 182 183 184 185
    @! ()
where
    add list
        =   addTask
        >>- \i ->
            upd (\is -> is++[i]) refsList
        >>| appendTask Embedded add list
        >>| removeWhenStable (detailsTask i) list

    removeWhenStable t l = t >>* [OnValue (ifStable (\v -> get (taskListSelfId l) >>- \id -> removeTask id l @! v))]

186
manageBackgroundTask :: !d !String !String (Task a) -> Task () | toPrompt d & iTask a
187
manageBackgroundTask d identity title task
188
    =   viewSharedInformation d [ViewAs (view title)] taskPid
Bas Lijnse's avatar
Bas Lijnse committed
189 190
    >^* [OnAction (Action "Start") (ifValue isNothing startTask)
        ,OnAction (Action "Stop") (ifValue isJust stopTask)
191 192 193
        ]
    @!  ()
where
Bas Lijnse's avatar
Bas Lijnse committed
194
    view title t = let (color,statusmsg) = status t in (color,title +++ " is " +++ statusmsg)
195 196 197
    status Nothing              = (LightOff,"not activated")
    status (Just (taskId,Unstable))  = (LightOnGreen,"running" <+++ taskId )
    status (Just (_,Stable))    = (LightOnGreen,"stopped")
Bas Lijnse's avatar
Bas Lijnse committed
198
    status (Just (_,Exception _)) = (LightOnRed,"stopped with an error")
199

200
    taskPid = mapRead find (sdsFocus ("name",identity) taskInstancesByAttribute)
201 202 203 204 205
    where
        find instances = case [(instanceNo,value) \\ {TaskInstance|instanceNo,value,attributes} <- instances | hasName identity attributes] of
            [(i,v):_]   = Just (TaskId i 0,v)
            _           = Nothing

206
        hasName name attributes = maybe False ((==) name) ('DM'.get "name" attributes)
207 208 209 210 211 212

    startTask _ = appendTask (NamedDetached identity defaultValue True) (removeWhenStable (task @! ())) topLevelTasks @! ()
    stopTask (Just (taskId,_)) = removeTask taskId topLevelTasks @! ()

    removeWhenStable t l = t >>* [OnValue (ifStable (\_ -> get (taskListSelfId l) >>- \id -> removeTask id l @? const NoValue))]

213
syncNetworkChannel      :: String Int String (String -> m) (m -> String) (Shared sds ([m],Bool,[m],Bool)) -> Task () | iTask m & RWShared sds
214
syncNetworkChannel server port msgSeparator decodeFun encodeFun channel
215
    = tcpconnect server port channel {ConnectionHandlers|onConnect=onConnect,onData=onData,onShareChange=onShareChange,onDisconnect=onDisconnect} @! ()
216
where
217
    onConnect _ _ (received,receiveStopped,send,sendStopped)
218
        = (Ok "",if (not (isEmpty send)) (Just (received,False,[],sendStopped)) Nothing, map encodeFun send,False)
219

220
	onData newData acc (received,receiveStopped,send,sendStopped)
221 222 223
        # [acc:msgs]    = reverse (split msgSeparator (concat [acc,newData]))
		# write         = if (not (isEmpty msgs && isEmpty send))
            (Just (received ++ map decodeFun (reverse msgs),receiveStopped,[],sendStopped))
224 225 226
            Nothing
        = (Ok acc,write,map encodeFun send,False)

227 228 229
	onShareChange acc (received,receiveStopped,send,sendStopped)
		= (Ok acc,Nothing,[],False)

230
    onDisconnect l (received,receiveStopped,send,sendStopped)
231 232
		= (Ok l,Just (received,True,send,sendStopped))

233
consumeNetworkStream    :: ([m] -> Task ()) (Shared sds ([m],Bool,[m],Bool)) -> Task () | iTask m & RWShared sds
234 235 236 237 238 239 240
consumeNetworkStream processTask channel
    = ((watch channel >>* [OnValue (ifValue ifProcess process)]) <! id) @! ()
where
    ifProcess (received,receiveStopped,_,_)
        = receiveStopped || (not (isEmpty received))

    process (received,receiveStopped,_,_)
241
        =   upd empty channel
242 243
        >>| if (isEmpty received) (return ()) (processTask received)
        @!  receiveStopped
244 245 246 247

	empty :: ([m],Bool,[m],Bool) -> ([m],Bool,[m],Bool)
	empty (_,rs,s,ss) = ([],rs,s,ss)