Commit e268a192 authored by Bas Lijnse's avatar Bas Lijnse

Merge branch 'master' into 162-including-svg-throws-nomatch-in-sapl-in-some-cases

parents cf952701 1a816fff
Version: 1.0 Version: 1.0
Environment Environment
EnvironmentName: iTasks EnvironmentName: iTasks
EnvironmentPaths EnvironmentPaths
Path: {Application}/lib/StdEnv Path: {Application}/lib/StdEnv
Path: {Application}/lib/Generics Path: {Application}/lib/Generics
Path: {Application}/lib/Dynamics Path: {Application}/lib/Dynamics
Path: {Application}/lib/TCPIP Path: {Application}/lib/TCPIP
Path: {Application}/lib/Platform Path: {Application}/lib/Platform
Path: {Application}/lib/Platform/Deprecated/StdLib Path: {Application}/lib/Platform/Deprecated/StdLib
Path: {Application}/lib/Sapl Path: {Application}/lib/Sapl
Path: {Application}/lib/GraphCopy Path: {Application}/lib/GraphCopy
Path: {Application}/lib/iTasks Path: {Application}/lib/iTasks
EnvironmentCompiler: lib/exe/cocl:-dynamics -sapl EnvironmentCompiler: lib/exe/cocl:-dynamics -sapl
EnvironmentCodeGen: lib/exe/cg EnvironmentCodeGen: lib/exe/cg
EnvironmentLinker: /usr/bin/gcc|lib/exe/sapl-collector-linker|lib/exe/itasks-web-collector EnvironmentLinker: /usr/bin/gcc|lib/exe/sapl-collector-linker|lib/exe/itasks-web-collector
EnvironmentDynLink: /usr/bin/gcc EnvironmentDynLink: /usr/bin/gcc
EnvironmentVersion: 920 EnvironmentVersion: 920
EnvironmentRedirect: False EnvironmentRedirect: False
EnvironmentCompileMethod: Pers EnvironmentCompileMethod: Pers
EnvironmentProcessor: I386 EnvironmentProcessor: I386
Environment64BitProcessor: True Environment64BitProcessor: True
...@@ -10,7 +10,7 @@ import Incidone.OP.Concepts, Incidone.OP.SDSs, Incidone.OP.Conversions ...@@ -10,7 +10,7 @@ import Incidone.OP.Concepts, Incidone.OP.SDSs, Incidone.OP.Conversions
import Incidone.OP.IncidentManagementTasks, Incidone.OP.ContactManagementTasks, Incidone.OP.CommunicationManagementTasks import Incidone.OP.IncidentManagementTasks, Incidone.OP.ContactManagementTasks, Incidone.OP.CommunicationManagementTasks
import qualified Data.Map as DM import qualified Data.Map as DM
import Data.Tuple, Data.Functor, Data.List, Text, Text.HTML import Data.Tuple, Data.Functor, Data.List, Data.Either, Text, Text.HTML
//Extensions //Extensions
import Incidone.Extensions.CrewLists import Incidone.Extensions.CrewLists
...@@ -43,7 +43,7 @@ where ...@@ -43,7 +43,7 @@ where
filterFun contactNo (_,_,{ActionStatus|contacts}) = isMember contactNo contacts filterFun contactNo (_,_,{ActionStatus|contacts}) = isMember contactNo contacts
actionStatusesOfCurrentContact :: ROShared () [(InstanceNo,InstanceNo,ActionStatus)] actionStatusesOfCurrentContact :: ROShared () [(InstanceNo,InstanceNo,ActionStatus)]
actionStatusesOfCurrentContact = sdsSequence "actionStatusesOfCurrentContact" (\_ r -> r) snd writel writer currentUserContactNo actionStatusesByContact actionStatusesOfCurrentContact = sdsSequence "actionStatusesOfCurrentContact" id (\_ r -> r) (\_ _ -> Right snd) writel writer currentUserContactNo actionStatusesByContact
where where
writel = SDSWriteConst (\_ _ -> Ok Nothing) writel = SDSWriteConst (\_ _ -> Ok Nothing)
writer = SDSWriteConst (\_ _ -> Ok Nothing) writer = SDSWriteConst (\_ _ -> Ok Nothing)
...@@ -100,7 +100,7 @@ fromSelfActionStatus status (_,items) = case [i \\ i=:{TaskListItem|taskId,self} ...@@ -100,7 +100,7 @@ fromSelfActionStatus status (_,items) = case [i \\ i=:{TaskListItem|taskId,self}
[{TaskListItem|taskId,attributes}:_] = Ok (Just [(taskId,fromActionStatus status attributes)]) [{TaskListItem|taskId,attributes}:_] = Ok (Just [(taskId,fromActionStatus status attributes)])
_ = Error (exception "Task id not found in self management share") _ = Error (exception "Task id not found in self management share")
selfActionStatus :: (SharedTaskList a) -> Shared ActionStatus selfActionStatus :: (SharedTaskList a) -> Shared ActionStatus | iTask a
selfActionStatus list = sdsFocus taskListFilter (mapReadWriteError (toSelfActionStatus,fromSelfActionStatus) list) selfActionStatus list = sdsFocus taskListFilter (mapReadWriteError (toSelfActionStatus,fromSelfActionStatus) list)
where where
taskListFilter = {TaskListFilter|onlyIndex=Nothing,onlyTaskId=Nothing,onlySelf=False taskListFilter = {TaskListFilter|onlyIndex=Nothing,onlyTaskId=Nothing,onlySelf=False
......
implementation module Incidone.ContactPosition implementation module Incidone.ContactPosition
import iTasks, iTasks.UI.Editor, iTasks.UI.Editor.Builtin, iTasks.UI.Editor.Combinators, iTasks.UI.Definition import iTasks, iTasks.UI.Editor, iTasks.UI.Editor.Controls, iTasks.UI.Editor.Modifiers, iTasks.UI.Definition
import qualified Data.Map as DM import qualified Data.Map as DM
import Data.Functor, Data.List, Text import Data.Functor, Data.List, Text
import qualified Text.Parsers.ZParsers.ParsersKernel as PK import qualified Text.Parsers.ZParsers.ParsersKernel as PK
...@@ -15,7 +15,7 @@ import Incidone.Util.TaskPatterns ...@@ -15,7 +15,7 @@ import Incidone.Util.TaskPatterns
derive JSONEncode ContactPosition derive JSONEncode ContactPosition
derive JSONDecode ContactPosition derive JSONDecode ContactPosition
gEditor{|ContactPosition|} = liftEditor printPosition parsePosition (textField 'DM'.newMap) gEditor{|ContactPosition|} = bijectEditorValue printPosition parsePosition textField
gText{|ContactPosition|} _ val = [maybe "" printPosition val] gText{|ContactPosition|} _ val = [maybe "" printPosition val]
derive gDefault ContactPosition derive gDefault ContactPosition
......
...@@ -90,7 +90,7 @@ composeEmailMessage communicationNo ...@@ -90,7 +90,7 @@ composeEmailMessage communicationNo
>>| updateMessageMeta communicationNo >>| updateMessageMeta communicationNo
||- ((composeAndSendMessage communicationNo message transmitEmailMessage ||- ((composeAndSendMessage communicationNo message transmitEmailMessage
-&&- -&&-
relateMessageToIncidents communicationNo) <<@ ArrangeWithTabs) relateMessageToIncidents communicationNo) <<@ ArrangeWithTabs True)
<<@ ArrangeWithSideBar 0 TopSide 60 False <<@ ArrangeWithSideBar 0 TopSide 60 False
<<@ Title "Compose E-mail" <<@ Title "Compose E-mail"
/* <<@ AfterLayout (uiDefSetSize (ExactSize 800) (ExactSize 600) ) */ //FIXME /* <<@ AfterLayout (uiDefSetSize (ExactSize 800) (ExactSize 600) ) */ //FIXME
...@@ -105,7 +105,7 @@ composeP2000Message communicationNo ...@@ -105,7 +105,7 @@ composeP2000Message communicationNo
>>| updateMessageMeta communicationNo >>| updateMessageMeta communicationNo
||- ((composeAndSendMessage communicationNo message transmitP2000Message ||- ((composeAndSendMessage communicationNo message transmitP2000Message
-&&- -&&-
relateMessageToIncidents communicationNo) <<@ ArrangeWithTabs) relateMessageToIncidents communicationNo) <<@ ArrangeWithTabs True)
<<@ ArrangeWithSideBar 0 TopSide 60 False <<@ ArrangeWithSideBar 0 TopSide 60 False
<<@ Title "Compose P2000 message" <<@ Title "Compose P2000 message"
/* <<@ AfterLayout (uiDefSetSize (ExactSize 800) (ExactSize 600)) */ //FIXME /* <<@ AfterLayout (uiDefSetSize (ExactSize 800) (ExactSize 600)) */ //FIXME
...@@ -290,7 +290,7 @@ manageLinkedIncidentInfo incidentNo ...@@ -290,7 +290,7 @@ manageLinkedIncidentInfo incidentNo
manageVoiceCallContent :: CommunicationType CommunicationNo -> Task () manageVoiceCallContent :: CommunicationType CommunicationNo -> Task ()
manageVoiceCallContent type communicationNo manageVoiceCallContent type communicationNo
= updateCallNotes -|| relateMessageToIncidents communicationNo <<@ ArrangeWithTabs = updateCallNotes -|| relateMessageToIncidents communicationNo <<@ ArrangeWithTabs True
where where
updateCallNotes updateCallNotes
= updateSharedInformation (Title "Notes") [] (callNotes type) //<<@ FillNotes //FIXME = updateSharedInformation (Title "Notes") [] (callNotes type) //<<@ FillNotes //FIXME
......
...@@ -44,4 +44,4 @@ deleteCommunicationMean :: CommunicationMeanId -> Task () ...@@ -44,4 +44,4 @@ deleteCommunicationMean :: CommunicationMeanId -> Task ()
//Check credentials for contacts that can log in //Check credentials for contacts that can log in
verifyContactCredentials :: Credentials -> Task (Maybe User) verifyContactCredentials :: Credentials -> Task (Maybe User)
viewContactsOnMap :: (ReadWriteShared [ContactGeo] w) (Shared (Maybe (Either ContactNo MMSI))) -> Task (Either ContactNo MMSI) viewContactsOnMap :: (ReadWriteShared [ContactGeo] w) (Shared (Maybe (Either ContactNo MMSI))) -> Task (Either ContactNo MMSI) | iTask w
...@@ -7,9 +7,10 @@ import Incidone.Util.TaskPatterns ...@@ -7,9 +7,10 @@ import Incidone.Util.TaskPatterns
import Incidone.DeviceBased.VideoWall import Incidone.DeviceBased.VideoWall
import Incidone.Extensions.CrewLists //For demo import Incidone.Extensions.CrewLists //For demo
import qualified Data.Map as DM import qualified Data.Map as DM
import Text, Text.HTML, Data.Either import Text, Text.HTML, Data.Either, Data.Functor
import iTasks.UI.Editor.Builtin import iTasks.UI.Editor.Controls
CONVERT_BIN :== "/opt/local/bin/convert" CONVERT_BIN :== "/opt/local/bin/convert"
//CONVERT_BIN :== "/usr/bin/convert" //CONVERT_BIN :== "/usr/bin/convert"
...@@ -23,7 +24,7 @@ selectContact = withShared Nothing ...@@ -23,7 +24,7 @@ selectContact = withShared Nothing
(selectContactFromLists sel <<@ Title "Browse") (selectContactFromLists sel <<@ Title "Browse")
-||- -||-
(viewContactsOnMap mapContacts sel <<@ Title "Map") (viewContactsOnMap mapContacts sel <<@ Title "Map")
<<@ ArrangeWithTabs <<@ ArrangeWithTabs True
) )
where where
mapContacts = mapRead (\(x,y) -> x++y) (contactsOfOpenIncidentsGeo |+| contactsProvidingHelpGeo) mapContacts = mapRead (\(x,y) -> x++y) (contactsOfOpenIncidentsGeo |+| contactsProvidingHelpGeo)
...@@ -92,7 +93,7 @@ manageContactInformation ws contactNo ...@@ -92,7 +93,7 @@ manageContactInformation ws contactNo
,manageContactIncidents ws contactNo ,manageContactIncidents ws contactNo
,manageContactActions False contactNo ,manageContactActions False contactNo
,manageContactCrew` contactNo <<@ Title "Crew" ,manageContactCrew` contactNo <<@ Title "Crew"
] <<@ ArrangeWithTabs) @! () ] <<@ ArrangeWithTabs True) @! ()
where where
viewTitle contactNo = viewSharedTitle (mapRead contactTitle (sdsFocus contactNo contactByNo)) viewTitle contactNo = viewSharedTitle (mapRead contactTitle (sdsFocus contactNo contactByNo))
...@@ -551,7 +552,7 @@ verifyContactCredentials credentials ...@@ -551,7 +552,7 @@ verifyContactCredentials credentials
= get (sdsFocus credentials contactByCredentials) = get (sdsFocus credentials contactByCredentials)
@ fmap contactUser @ fmap contactUser
viewContactsOnMap :: (ReadWriteShared [ContactGeo] w) (Shared (Maybe (Either ContactNo MMSI))) -> Task (Either ContactNo MMSI) viewContactsOnMap :: (ReadWriteShared [ContactGeo] w) (Shared (Maybe (Either ContactNo MMSI))) -> Task (Either ContactNo MMSI) | iTask w
viewContactsOnMap sharedContacts sel viewContactsOnMap sharedContacts sel
= get (standardMapLayers |+| standardPerspective) = get (standardMapLayers |+| standardPerspective)
>>- \(baseLayers,perspective) -> >>- \(baseLayers,perspective) ->
...@@ -567,10 +568,10 @@ where ...@@ -567,10 +568,10 @@ where
mapState :: (Shared (Bool,ContactMapPerspective)) mapState :: (Shared (Bool,ContactMapPerspective))
(ReadWriteShared [ContactGeo] w) (ReadWriteShared [ContactGeo] w)
(Shared (Maybe (Either ContactNo MMSI))) -> (Shared (Maybe (Either ContactNo MMSI))) ->
ReadWriteShared ([(Bool,ContactGeo)], Maybe (Either ContactNo MMSI), ContactMapPerspective) (Maybe (Either ContactNo MMSI), ContactMapPerspective) ReadWriteShared ([(Bool,ContactGeo)], Maybe (Either ContactNo MMSI), ContactMapPerspective) (Maybe (Either ContactNo MMSI), ContactMapPerspective) | iTask w
mapState local contacts sel = sdsSequence "mapState" (\_ r -> r) read writel writer (local >+< sel) mapContacts mapState local contacts sel = sdsSequence "mapState" id (\_ r -> r) (\_ _ -> Right read) writel writer (local >+< sel) mapContacts
where where
mapContacts = sdsSelect "mapContacts" choose (\_ _ _ _ -> False) (\_ _ _ _ -> False) withoutAISContacts withAISContacts mapContacts = sdsSelect "mapContacts" choose (SDSNotifyConst (\_ _ _ -> False)) (SDSNotifyConst (\_ _ _ -> False)) withoutAISContacts withAISContacts
where where
choose ((withAIS,{ContactMapPerspective|bounds=Just bounds}),_) = (if withAIS (Right bounds) (Left bounds)) choose ((withAIS,{ContactMapPerspective|bounds=Just bounds}),_) = (if withAIS (Right bounds) (Left bounds))
choose _ = (Left defaultValue) choose _ = (Left defaultValue)
......
...@@ -28,7 +28,7 @@ manageIncidentInformation ws incidentNo ...@@ -28,7 +28,7 @@ manageIncidentInformation ws incidentNo
,(Embedded, \_ -> manageIncidentActions incidentNo) ,(Embedded, \_ -> manageIncidentActions incidentNo)
,(Embedded, \_ -> manageIncidentWeather incidentNo) ,(Embedded, \_ -> manageIncidentWeather incidentNo)
,(Embedded, \_ -> manageIncidentLog incidentNo) ,(Embedded, \_ -> manageIncidentLog incidentNo)
] [] <<@ ArrangeWithTabs) ] [] <<@ ArrangeWithTabs False)
@! () @! ()
//Basic incident information (title, summary, type, phase etc..) //Basic incident information (title, summary, type, phase etc..)
......
...@@ -5,14 +5,14 @@ import qualified Data.Map as DM ...@@ -5,14 +5,14 @@ import qualified Data.Map as DM
import Incidone.Configuration import Incidone.Configuration
import Incidone.OP.Concepts, Incidone.OP.Conversions import Incidone.OP.Concepts, Incidone.OP.Conversions
import Incidone.Util.SQLSDS import Incidone.Util.SQLSDS
import Data.Functor import Data.Functor, Data.Either
derive class iTask ContactFilter derive class iTask ContactFilter
dbReadSDS :: String -> ROShared QueryDef [r] | mbFromSQL r dbReadSDS :: String -> ROShared QueryDef [r] | mbFromSQL r & TC r
dbReadSDS notifyId = databaseDef >++> sqlReadSDS notifyId dbReadSDS notifyId = databaseDef >++> sqlReadSDS notifyId
dbReadWriteOneSDS :: String -> RWShared QueryDef r r | mbFromSQL, mbToSQL r & gDefault{|*|} r dbReadWriteOneSDS :: String -> RWShared QueryDef r r | mbFromSQL, mbToSQL r & gDefault{|*|} r & TC r
dbReadWriteOneSDS notifyId = databaseDef >++> sqlReadWriteOneSDS notifyId dbReadWriteOneSDS notifyId = databaseDef >++> sqlReadWriteOneSDS notifyId
dbLinkSDS :: String String String String -> RWShared (Maybe [Int]) [(Int,Int)] [(Int,Int)] dbLinkSDS :: String String String String -> RWShared (Maybe [Int]) [(Int,Int)] [(Int,Int)]
...@@ -481,7 +481,7 @@ where ...@@ -481,7 +481,7 @@ where
query group = Just (EqualsValue ("Contact","group") (toSQL group)) query group = Just (EqualsValue ("Contact","group") (toSQL group))
contactsOfOpenIncidentsShort :: ROShared () [ContactShortWithIncidents] contactsOfOpenIncidentsShort :: ROShared () [ContactShortWithIncidents]
contactsOfOpenIncidentsShort = sdsSequence "contactsOfOpenIncidentsShort" param read writel writer contactsOfOpenIncidentsShortBase openIncidentsByContactsShortIndexed contactsOfOpenIncidentsShort = sdsSequence "contactsOfOpenIncidentsShort" id param (\_ _ -> Right read) writel writer contactsOfOpenIncidentsShortBase openIncidentsByContactsShortIndexed
where where
writel = SDSWriteConst (\_ _ -> Ok Nothing) writel = SDSWriteConst (\_ _ -> Ok Nothing)
writer = SDSWriteConst (\_ _ -> Ok Nothing) writer = SDSWriteConst (\_ _ -> Ok Nothing)
...@@ -828,7 +828,8 @@ where ...@@ -828,7 +828,8 @@ where
_ = Nothing _ = Nothing
contactAIS :: ROShared ContactNo (Maybe AISContact) contactAIS :: ROShared ContactNo (Maybe AISContact)
contactAIS = sdsSequence "contactAIS" (\_ mbMMSI -> mbMMSI) snd (SDSWriteConst (\_ _ -> Ok Nothing)) (SDSWriteConst (\_ w -> Ok (Just w))) contactMMSI (roMaybe (toReadOnly AISContactByMMSI)) contactAIS = sdsSequence "contactAIS" id (\_ mbMMSI -> mbMMSI) (\_ _ -> Right snd) (SDSWriteConst (\_ _ -> Ok Nothing)) (SDSWriteConst (\_ w -> Ok (Just w)))
contactMMSI (roMaybe (toReadOnly AISContactByMMSI))
contactCommunications :: ROShared ContactNo [CommunicationDetails] contactCommunications :: ROShared ContactNo [CommunicationDetails]
contactCommunications = sdsTranslate "contactCommunications" cond filteredCommunications contactCommunications = sdsTranslate "contactCommunications" cond filteredCommunications
...@@ -957,7 +958,7 @@ where ...@@ -957,7 +958,7 @@ where
= (Ok (),cur) = (Ok (),cur)
currentUserAvatar :: ROShared () (Maybe ContactAvatar) currentUserAvatar :: ROShared () (Maybe ContactAvatar)
currentUserAvatar = sdsSequence "userContactNo" (\_ u -> userContactNo u) snd writel writer currentUser (roMaybe (mapRead Just (toReadOnly contactAvatar))) currentUserAvatar = sdsSequence "userContactNo" id (\_ u -> userContactNo u) (\_ _ -> Right snd) writel writer currentUser (roMaybe (mapRead Just (toReadOnly contactAvatar)))
where where
writel = SDSWriteConst (\_ _ -> Ok Nothing) writel = SDSWriteConst (\_ _ -> Ok Nothing)
writer = SDSWriteConst (\_ _ -> Ok Nothing) writer = SDSWriteConst (\_ _ -> Ok Nothing)
......
...@@ -61,7 +61,7 @@ where ...@@ -61,7 +61,7 @@ where
-||- -||-
(enterChoiceWithSharedAs (Title "Recent incidents") (enterChoiceWithSharedAs (Title "Recent incidents")
[ChooseFromGrid id] recentIncidentsDetails (\{IncidentDetails|incidentNo} -> incidentNo) /* <<@ AfterLayout (tweakUI fill) */) //FIXME [ChooseFromGrid id] recentIncidentsDetails (\{IncidentDetails|incidentNo} -> incidentNo) /* <<@ AfterLayout (tweakUI fill) */) //FIXME
) <<@ ArrangeWithTabs ) <<@ ArrangeWithTabs True
browseContacts :: Workspace -> Task () browseContacts :: Workspace -> Task ()
browseContacts ws browseContacts ws
......
...@@ -13,10 +13,12 @@ currentNotifications :: ReadOnlyShared [String] ...@@ -13,10 +13,12 @@ currentNotifications :: ReadOnlyShared [String]
currentNotifications = mapRead prj (currentDateTime |*| notifications) currentNotifications = mapRead prj (currentDateTime |*| notifications)
where where
prj (now,notifications) = [toString dt +++ msg \\ (dt,msg) <- notifications | limit now dt ] prj (now,notifications) = [toString dt +++ msg \\ (dt,msg) <- notifications | limit now dt ]
limit t1 t2 limit t1 t2 = False //FIXME: We need an non-pure function to convert the datetime values, we can't do that with a mapRead...
# (Timestamp s1) = datetimeToTimestamp t1 /*
# (Timestamp s1) = datetimeToTimestamp t1
# (Timestamp s2) = datetimeToTimestamp t2 # (Timestamp s2) = datetimeToTimestamp t2
= s1 - s2 < 3 = s1 - s2 < 3
*/
addNotification :: String -> Task () addNotification :: String -> Task ()
addNotification msg addNotification msg
......
...@@ -56,7 +56,7 @@ toOrderBySQL :: [RowOrderDef] -> String ...@@ -56,7 +56,7 @@ toOrderBySQL :: [RowOrderDef] -> String
fromSQLWithId :: [SQLValue] -> (Int,a) | mbFromSQL a fromSQLWithId :: [SQLValue] -> (Int,a) | mbFromSQL a
(>++>) infixl 6 :: (RWShared () SQLDatabaseDef SQLDatabaseDef) (RWShared (SQLDatabaseDef,p) r w) -> RWShared p r w | iTask p (>++>) infixl 6 :: (RWShared () SQLDatabaseDef SQLDatabaseDef) (RWShared (SQLDatabaseDef,p) r w) -> RWShared p r w | iTask p & TC r & TC w
sqlReadSDS :: String -> ROShared (SQLDatabaseDef,QueryDef) [r] | mbFromSQL r sqlReadSDS :: String -> ROShared (SQLDatabaseDef,QueryDef) [r] | mbFromSQL r
sqlReadWriteOneSDS :: String -> RWShared (SQLDatabaseDef,QueryDef) r r | mbFromSQL, mbToSQL r & gDefault{|*|} r sqlReadWriteOneSDS :: String -> RWShared (SQLDatabaseDef,QueryDef) r r | mbFromSQL, mbToSQL r & gDefault{|*|} r
...@@ -64,4 +64,4 @@ sqlLinkSDS :: String String String String-> RWShared (SQLDatabaseDef,Ma ...@@ -64,4 +64,4 @@ sqlLinkSDS :: String String String String-> RWShared (SQLDatabaseDef,Ma
groupByFst :: [(a,b)] -> Map a [b] | Eq a & Ord a groupByFst :: [(a,b)] -> Map a [b] | Eq a & Ord a
ungroupByFst :: (Map a [b]) -> [(a,b)] ungroupByFst :: (Map a [b]) -> [(a,b)]
roMaybe :: (RWShared p (Maybe r) ()) -> RWShared (Maybe p) (Maybe r) () | iTask p roMaybe :: (RWShared p (Maybe r) ()) -> RWShared (Maybe p) (Maybe r) () | iTask p & TC r
...@@ -147,8 +147,8 @@ fromSQLWithId :: [SQLValue] -> (Int,a) | mbFromSQL a ...@@ -147,8 +147,8 @@ fromSQLWithId :: [SQLValue] -> (Int,a) | mbFromSQL a
fromSQLWithId row = (fromSQL [last row],fromSQL (init row)) fromSQLWithId row = (fromSQL [last row],fromSQL (init row))
//UTIL SDS Combinators //UTIL SDS Combinators
(>++>) infixl 6 :: (RWShared () SQLDatabaseDef SQLDatabaseDef) (RWShared (SQLDatabaseDef,p) r w) -> RWShared p r w | iTask p (>++>) infixl 6 :: (RWShared () SQLDatabaseDef SQLDatabaseDef) (RWShared (SQLDatabaseDef,p) r w) -> RWShared p r w | iTask p & TC r & TC w
(>++>) db sds = sdsSequence ">++>" (\p db -> (db,p)) snd (SDSWriteConst (\_ _ -> Ok Nothing)) (SDSWriteConst (\_ w -> Ok (Just w))) (sdsFocus () db) sds (>++>) db sds = sdsSequence ">++>" id (\p db -> (db,p)) (\_ _ -> Right snd) (SDSWriteConst (\_ _ -> Ok Nothing)) (SDSWriteConst (\_ w -> Ok (Just w))) (sdsFocus () db) sds
sqlReadSDS :: String -> ROShared (SQLDatabaseDef,QueryDef) [r] | mbFromSQL r sqlReadSDS :: String -> ROShared (SQLDatabaseDef,QueryDef) [r] | mbFromSQL r
sqlReadSDS notifyId = sqlShare notifyId readFun writeFun sqlReadSDS notifyId = sqlShare notifyId readFun writeFun
...@@ -231,8 +231,8 @@ where ...@@ -231,8 +231,8 @@ where
ungroupByFst :: (Map a [b]) -> [(a,b)] ungroupByFst :: (Map a [b]) -> [(a,b)]
ungroupByFst index = flatten [[(a,b) \\ b <- bs] \\ (a,bs) <- 'DM'.toList index] ungroupByFst index = flatten [[(a,b) \\ b <- bs] \\ (a,bs) <- 'DM'.toList index]
roMaybe :: (RWShared p (Maybe r) ()) -> RWShared (Maybe p) (Maybe r) () | iTask p roMaybe :: (RWShared p (Maybe r) ()) -> RWShared (Maybe p) (Maybe r) () | iTask p & TC r
roMaybe sds = sdsSelect "roMaybe" choose (\_ _ _ _ -> False) (\_ _ _ _ -> False) (constShare Nothing) sds roMaybe sds = sdsSelect "roMaybe" choose (SDSNotifyConst (\_ _ _ -> False)) (SDSNotifyConst (\_ _ _ -> False)) (constShare Nothing) sds
where where
choose Nothing = Left () choose Nothing = Left ()
choose (Just p) = Right p choose (Just p) = Right p
......
...@@ -14,10 +14,10 @@ createNewIncident :: Task (Maybe IncidentNo) ...@@ -14,10 +14,10 @@ createNewIncident :: Task (Maybe IncidentNo)
createNewContact :: Task (Maybe ContactNo) createNewContact :: Task (Maybe ContactNo)
indexedStore :: String v -> RWShared k v v | Eq k & Ord k & iTask k & iTask v indexedStore :: String v -> RWShared k v v | Eq k & Ord k & iTask k & iTask v
sdsDeref :: (RWShared p [a] [a]) (a -> Int) (RWShared [Int] [b] x) ([a] [b] -> [c]) -> (RWShared p [c] [a]) sdsDeref :: (RWShared p [a] [a]) (a -> Int) (RWShared [Int] [b] x) ([a] [b] -> [c]) -> (RWShared p [c] [a]) | iTask p & TC a & TC b & TC c & TC x
// Information management // Information management
viewDetails :: !d (ReadOnlyShared (Maybe i)) (RWShared i c c) (c -> v) -> Task (Maybe v) | toPrompt d & iTask i & iTask v viewDetails :: !d (ReadOnlyShared (Maybe i)) (RWShared i c c) (c -> v) -> Task (Maybe v) | toPrompt d & iTask i & iTask v & iTask c
optionalNewOrOpen :: (String,Task ()) (String,i -> Task ()) Workspace (ReadOnlyShared (Maybe i)) -> Task () | iTask i optionalNewOrOpen :: (String,Task ()) (String,i -> Task ()) Workspace (ReadOnlyShared (Maybe i)) -> Task () | iTask i
......
...@@ -3,7 +3,7 @@ implementation module Incidone.Util.TaskPatterns ...@@ -3,7 +3,7 @@ implementation module Incidone.Util.TaskPatterns
import iTasks, iTasks.Extensions.Dashboard import iTasks, iTasks.Extensions.Dashboard
import iTasks.UI.Definition import iTasks.UI.Definition
import Incidone.OP.IncidentManagementTasks, Incidone.OP.ContactManagementTasks import Incidone.OP.IncidentManagementTasks, Incidone.OP.ContactManagementTasks
import Text, Data.Functor, Data.Either import Text, Data.Functor, Data.Either, Data.Maybe
import qualified Data.Map as DM import qualified Data.Map as DM
import StdMisc import StdMisc
...@@ -35,25 +35,32 @@ where ...@@ -35,25 +35,32 @@ where
read p mapping = fromMaybe def ('DM'.get p mapping) read p mapping = fromMaybe def ('DM'.get p mapping)
write p mapping v = ('DM'.put p v mapping,(==) p) write p mapping v = ('DM'.put p v mapping,(==) p)
sdsDeref :: (RWShared p [a] [a]) (a -> Int) (RWShared [Int] [b] x) ([a] [b] -> [c]) -> (RWShared p [c] [a]) sdsDeref :: (RWShared p [a] [a]) (a -> Int) (RWShared [Int] [b] x) ([a] [b] -> [c]) -> (RWShared p [c] [a]) | iTask p & TC a & TC b & TC c & TC x
sdsDeref sds1 toRef sds2 merge = sdsSequence "sdsDeref" (\_ r -> map toRef r) read writel writer sds1 sds2 sdsDeref sds1 toRef sds2 merge = sdsSequence "sdsDeref" paraml paramr (\_ _ -> Right read) writel writer sds1 sds2
where where
paraml p = p
paramr p r1 = map toRef r1
param _ r = (\_ r -> map toRef r) param _ r = (\_ r -> map toRef r)
read (as,bs) = merge as bs read (as,bs) = merge as bs
writel = SDSWriteConst (\_ w -> Ok (Just w)) writel = SDSWriteConst (\_ w -> Ok (Just w))
writer = SDSWriteConst (\_ _ -> Ok Nothing) writer = SDSWriteConst (\_ _ -> Ok Nothing)
viewDetails :: !d (ReadOnlyShared (Maybe i)) (RWShared i c c) (c -> v) -> Task (Maybe v) | toPrompt d & iTask i & iTask v viewDetails :: !d (ReadOnlyShared (Maybe i)) (RWShared i c c) (c -> v) -> Task (Maybe v) | toPrompt d & iTask i & iTask v & iTask c
viewDetails desc sel target prj = viewSharedInformation desc [] (mapRead (fmap prj) targetShare) viewDetails desc sel target prj = viewSharedInformation desc [] (mapRead (fmap prj) (targetShare sel target))
where where
targetShare = sdsSequence "viewDetailsSeq" (\_ i -> i) snd writel writer sel valueShare targetShare :: (RWShared () (Maybe i) ()) (RWShared i c c) -> RWShared () (Maybe c) () | iTask i & iTask c
targetShare sel target = sdsSequence "viewDetailsSeq" id (\_ i -> i) (\_ _ -> Right snd) writel writer sel (valueShare target)
where where
writel = SDSWriteConst (\_ _ -> Ok Nothing) writel = SDSWriteConst (\_ _ -> Ok Nothing)
writer = SDSWriteConst (\_ _ -> Ok Nothing) writer = SDSWriteConst (\_ _ -> Ok Nothing)
valueShare = sdsSelect "viewDetailsValue" param (\_ _ _ _ -> False) (\_ _ _ _ -> False) (constShare Nothing) (mapRead Just (toReadOnly target))
param Nothing = Left () valueShare :: (RWShared i c c) -> RWShared (Maybe i) (Maybe c) () | iTask i & iTask c
param (Just i) = Right i valueShare target = sdsSelect "viewDetailsValue" param (SDSNotifyConst (\_ _ _ -> False)) (SDSNotifyConst (\_ _ _ -> False))
(constShare Nothing) (mapRead Just (toReadOnly target))
where
param Nothing = Left ()
param (Just i) = Right i
optionalNewOrOpen :: (String,Task ()) (String,i -> Task ()) Workspace (ReadOnlyShared (Maybe i)) -> Task () | iTask i optionalNewOrOpen :: (String,Task ()) (String,i -> Task ()) Workspace (ReadOnlyShared (Maybe i)) -> Task () | iTask i
optionalNewOrOpen (newLabel,newTask) (openLabel,openTask) ws selection optionalNewOrOpen (newLabel,newTask) (openLabel,openTask) ws selection
......
...@@ -88,7 +88,7 @@ where ...@@ -88,7 +88,7 @@ where
>>* [OnAction (Action "Log out") (always (return ()))] >>* [OnAction (Action "Log out") (always (return ()))]
) <<@ ApplyLayout layoutControlDash ) <<@ ApplyLayout layoutControlDash
workOnTasks = doIndependent tasks <<@ ArrangeWithTabs workOnTasks = doIndependent tasks <<@ ArrangeWithTabs True
layoutControlDash = foldl1 sequenceLayouts layoutControlDash = foldl1 sequenceLayouts
[moveSubUIs (SelectByPath [0,0]) [] 1 [moveSubUIs (SelectByPath [0,0]) [] 1
......
...@@ -137,7 +137,7 @@ startEngineWithOptions initFun publishable world ...@@ -137,7 +137,7 @@ startEngineWithOptions initFun publishable world
where where
tcpTasks serverPort keepaliveTime = [(serverPort,httpServer serverPort keepaliveTime (engineWebService publishable) allUIChanges)] tcpTasks serverPort keepaliveTime = [(serverPort,httpServer serverPort keepaliveTime (engineWebService publishable) allUIChanges)]
engineTasks = engineTasks =
[BackgroundTask updateClocks [BackgroundTask updateClock
,BackgroundTask (processEvents MAX_EVENTS)