Commit be08aea5 authored by Camil Staps's avatar Camil Staps 🚀

Merge branch '337-runtime-error-with-updatesharedas-2' into 'master'

fix interact with invalid intermediate states

Closes #337

See merge request !325
parents baa90b4e 131c56ee
Pipeline #29917 passed with stage
in 4 minutes and 39 seconds
...@@ -670,7 +670,7 @@ updateActionStatus current = withShared current ...@@ -670,7 +670,7 @@ updateActionStatus current = withShared current
-|| (Hint "Incidents:" @>> updateSharedIncidentRefList True (incidents updating)) -|| (Hint "Incidents:" @>> updateSharedIncidentRefList True (incidents updating))
) <<@ (Title "Update action") ) <<@ (Title "Update action")
where where
updateMeta status = updateSharedInformation [UpdateSharedAs toPrj fromPrj const] status updateMeta status = updateSharedInformation [UpdateSharedAs toPrj fromPrj (const o Just)] status
where where
toPrj {ActionStatus|title,description} = {ItemMeta|title=title,description=description} toPrj {ActionStatus|title,description} = {ItemMeta|title=title,description=description}
fromPrj status {ItemMeta|title,description} = {ActionStatus|status & title=title,description=description} fromPrj status {ItemMeta|title,description} = {ActionStatus|status & title=title,description=description}
......
...@@ -30,7 +30,7 @@ where ...@@ -30,7 +30,7 @@ where
= get (standardMapLayers |*| standardPerspective) = get (standardMapLayers |*| standardPerspective)
>>- \(baseLayers,perspective) -> >>- \(baseLayers,perspective) ->
withShared perspective withShared perspective
\p -> Title title @>> updateSharedInformation [UpdateSharedAs (toMap baseLayers) fromMap const] (p >*| mapContacts) @ fst \p -> Title title @>> updateSharedInformation [UpdateSharedAs (toMap baseLayers) fromMap (const o Just)] (p >*| mapContacts) @ fst
//<<@ AfterLayout (tweakUI fill) //FIXME //<<@ AfterLayout (tweakUI fill) //FIXME
@ WallOverview @ WallOverview
where where
......
...@@ -55,7 +55,7 @@ where ...@@ -55,7 +55,7 @@ where
refs = sdsFocus contactNo crewAliasListsStore refs = sdsFocus contactNo crewAliasListsStore
manageCurrentItems manageCurrentItems
= Hint "Manage crew list" @>> updateSharedInformation [UpdateSharedAs toPrj fromPrj const] items = Hint "Manage crew list" @>> updateSharedInformation [UpdateSharedAs toPrj fromPrj (const o Just)] items
where where
items = sdsDeref refs snd contactsByNosShort derefAliasList items = sdsDeref refs snd contactsByNosShort derefAliasList
toPrj l = [(contactIdentity c, aNo, contactTitle c)\\(aNo,c) <-l] toPrj l = [(contactIdentity c, aNo, contactTitle c)\\(aNo,c) <-l]
......
...@@ -397,9 +397,9 @@ updateContactPosition contactNo ...@@ -397,9 +397,9 @@ updateContactPosition contactNo
>>- \({Contact|name,type,position},baseLayers) -> >>- \({Contact|name,type,position},baseLayers) ->
withShared (position,initPerspective position) withShared (position,initPerspective position)
\tmpInfo -> \tmpInfo ->
(Title "Position update" @>> Hint ("Update position of contact "<+++ name) @>> updateSharedInformation [UpdateSharedAs fst (\(_,y) x -> (x,y)) const] tmpInfo (Title "Position update" @>> Hint ("Update position of contact "<+++ name) @>> updateSharedInformation [UpdateSharedAs fst (\(_,y) x -> (x,y)) (const o Just)] tmpInfo
-||- -||-
updateSharedInformation [UpdateSharedAs (toMap baseLayers) (fromMap baseLayers) const] tmpInfo updateSharedInformation [UpdateSharedAs (toMap baseLayers) (fromMap baseLayers) (const o Just)] tmpInfo
-||- -||-
(Hint "Search the web" @>> viewSharedInformation [ViewAs (toSearchURLs o fst)] tmpInfo) (Hint "Search the web" @>> viewSharedInformation [ViewAs (toSearchURLs o fst)] tmpInfo)
) @ fst ) @ fst
...@@ -446,7 +446,7 @@ updateSharedContactRefList refs ...@@ -446,7 +446,7 @@ updateSharedContactRefList refs
>^* [OnAction (Action "Add") (always (addItem <<@ InWindow))] >^* [OnAction (Action "Add") (always (addItem <<@ InWindow))]
where where
manageCurrentItems manageCurrentItems
= updateSharedInformation [UpdateSharedAs toPrj fromPrj const] items @ map contactIdentity = updateSharedInformation [UpdateSharedAs toPrj fromPrj (const o Just)] items @ map contactIdentity
where where
items = sdsDeref refs id contactsByNosShort (\_ cs -> cs) items = sdsDeref refs id contactsByNosShort (\_ cs -> cs)
toPrj l = [(contactIdentity c,contactTitle c) \\ c <-l] toPrj l = [(contactIdentity c,contactTitle c) \\ c <-l]
...@@ -564,9 +564,9 @@ viewContactsOnMap sharedContacts sel ...@@ -564,9 +564,9 @@ viewContactsOnMap sharedContacts sel
>>- \(baseLayers,perspective) -> >>- \(baseLayers,perspective) ->
withShared (False,perspective) withShared (False,perspective)
\localState -> \localState ->
Hint "Show AIS contacts:" @>> updateSharedInformation [UpdateSharedAs fst (\(_,y) x -> (x,y)) const] localState Hint "Show AIS contacts:" @>> updateSharedInformation [UpdateSharedAs fst (\(_,y) x -> (x,y)) (const o Just)] localState
||- ||-
(updateSharedInformation [UpdateSharedAs (toPrj baseLayers) fromPrj const] (mapState localState sharedContacts sel)) @ (\(a,b,c) -> (b,c)) (updateSharedInformation [UpdateSharedAs (toPrj baseLayers) fromPrj (const o Just)] (mapState localState sharedContacts sel)) @ (\(a,b,c) -> (b,c))
>^* [OnAction (Action "/Share map to wall") (hasValue sharePerspective) >^* [OnAction (Action "/Share map to wall") (hasValue sharePerspective)
] ]
@? selection @? selection
......
...@@ -172,7 +172,7 @@ updateSharedIncidentRefList compact refs ...@@ -172,7 +172,7 @@ updateSharedIncidentRefList compact refs
>^* [OnAction (Action "Add") (always (addItem <<@ InWindow))] >^* [OnAction (Action "Add") (always (addItem <<@ InWindow))]
where where
manageCurrentItems manageCurrentItems
= updateSharedInformation [UpdateSharedAs toPrj fromPrj const] items @ map incidentIdentity = updateSharedInformation [UpdateSharedAs toPrj fromPrj (const o Just)] items @ map incidentIdentity
where where
items = sdsDeref refs id incidentsByNosShort (\_ is -> is) items = sdsDeref refs id incidentsByNosShort (\_ is -> is)
toPrj l = [(incidentIdentity i,incidentTitle i) \\i <-l] toPrj l = [(incidentIdentity i,incidentTitle i) \\i <-l]
......
...@@ -229,7 +229,7 @@ configureMaps ...@@ -229,7 +229,7 @@ configureMaps
where where
previewMapLayers :: Task ContactMapPerspective previewMapLayers :: Task ContactMapPerspective
previewMapLayers = withShared defaultValue previewMapLayers = withShared defaultValue
\perspective -> (Title "Preview" @>> updateSharedInformation [UpdateSharedAs toPrj fromPrj const] (perspective >*| standardMapLayers)) <<@ ApplyLayout flexMap @ fst \perspective -> (Title "Preview" @>> updateSharedInformation [UpdateSharedAs toPrj fromPrj (const o Just)] (perspective >*| standardMapLayers)) <<@ ApplyLayout flexMap @ fst
where where
toPrj (perspective,layers) = toLeafletMap {ContactMap|defaultValue & perspective=perspective,layers=layers} toPrj (perspective,layers) = toLeafletMap {ContactMap|defaultValue & perspective=perspective,layers=layers}
fromPrj _ {LeafletMap|perspective} = fromLeafletPerspective perspective fromPrj _ {LeafletMap|perspective} = fromLeafletPerspective perspective
......
...@@ -62,7 +62,7 @@ actorWithInstructions user ...@@ -62,7 +62,7 @@ actorWithInstructions user
pickStartRoom :: Task Coord3D pickStartRoom :: Task Coord3D
pickStartRoom pickStartRoom
= Hint "Which room do you want to start in?" @>> updateInformationWithShared = Hint "Which room do you want to start in?" @>> updateInformationWithShared
[UpdateSharedUsing id (const snd) const editor] [UpdateSharedUsing id (const snd) (const o Just) editor]
(maps2DShare |*| myNetwork) NoAction (maps2DShare |*| myNetwork) NoAction
>>* [OnValue (\v -> case v of >>* [OnValue (\v -> case v of
Value (FocusOnSection c3d) _ = Just (return c3d) Value (FocusOnSection c3d) _ = Just (return c3d)
...@@ -387,7 +387,7 @@ mkSection :: MyDrawMapForActor ...@@ -387,7 +387,7 @@ mkSection :: MyDrawMapForActor
mkSection mkSection
= \user shStatusMap shUserActor shSectionInventoryMap -> = \user shStatusMap shUserActor shSectionInventoryMap ->
Title "Section Status" @>> updateSharedInformation Title "Section Status" @>> updateSharedInformation
[UpdateSharedUsing id (\_ _ -> ()) const editor] [UpdateSharedUsing id (\_ _ -> ()) (const o Just) editor]
(sectionForUserShare user |*| myNetwork |*| myDevices |*| shStatusMap |*| sectionUsersShare |*| myUserActorMap |*| shSectionInventoryMap |*| lockedExitsShare |*| lockedHopsShare |*| maps2DShare) (sectionForUserShare user |*| myNetwork |*| myDevices |*| shStatusMap |*| sectionUsersShare |*| myUserActorMap |*| shSectionInventoryMap |*| lockedExitsShare |*| lockedHopsShare |*| maps2DShare)
@! () @! ()
where where
......
...@@ -184,7 +184,7 @@ intMapCrudWith descr cos eos vos uos mkId share = Title descr @>> crudWith cos e ...@@ -184,7 +184,7 @@ intMapCrudWith descr cos eos vos uos mkId share = Title descr @>> crudWith cos e
graphicalMapEditor :: Task () graphicalMapEditor :: Task ()
graphicalMapEditor graphicalMapEditor
= Title "Graphical map editor" @>> updateSharedInformation = Title "Graphical map editor" @>> updateSharedInformation
[UpdateSharedUsing id (const fst) const imageEditor] [UpdateSharedUsing id (const fst) (const o Just) imageEditor]
(sharedEditShip >*| (myInventoryMap |*| myNetwork |*| myDevices)) @! () (sharedEditShip >*| (myInventoryMap |*| myNetwork |*| myDevices)) @! ()
@! () @! ()
where where
...@@ -199,8 +199,8 @@ where ...@@ -199,8 +199,8 @@ where
editLayout :: Task () editLayout :: Task ()
editLayout editLayout
= allTasks [ graphicalMapEditor = allTasks [ graphicalMapEditor
, Title "Edit map dimensions" @>> updateSharedInformation [UpdateSharedAs toMapsForm fromMapsForm const] maps2DShare @! () , Title "Edit map dimensions" @>> updateSharedInformation [UpdateSharedAs toMapsForm fromMapsForm (const o Just)] maps2DShare @! ()
, Title "Edit map" @>> updateSharedInformation [UpdateSharedAs toMapActionForm fromMapActionForm const] sharedEditShip @! () , Title "Edit map" @>> updateSharedInformation [UpdateSharedAs toMapActionForm fromMapActionForm (const o Just)] sharedEditShip @! ()
, (watch maps2DShare , (watch maps2DShare
-&&- (Title "Quick borders" @>> enterChoiceWithShared [] (mapRead (\ship -> [mapId \\ {Map2D | mapId} <- ship]) maps2DShare)) -&&- (Title "Quick borders" @>> enterChoiceWithShared [] (mapRead (\ship -> [mapId \\ {Map2D | mapId} <- ship]) maps2DShare))
>>* [ OnAction (Action "Add outer borders" ) (hasValue (uncurry (editOuterBorders Wall))) >>* [ OnAction (Action "Add outer borders" ) (hasValue (uncurry (editOuterBorders Wall)))
...@@ -249,7 +249,7 @@ editSectionContents :: Task () ...@@ -249,7 +249,7 @@ editSectionContents :: Task ()
editSectionContents editSectionContents
= allTasks [ graphicalMapEditor = allTasks [ graphicalMapEditor
, withSelectedSection ( , withSelectedSection (
\mid c2d -> (Title (mkDesc mid c2d "Inventory")) @>> updateSharedInformation [UpdateSharedAs fromInv toInv const] (sdsFocus (mid, c2d) inventoryInSectionShare) \mid c2d -> (Title (mkDesc mid c2d "Inventory")) @>> updateSharedInformation [UpdateSharedAs fromInv toInv (const o Just)] (sdsFocus (mid, c2d) inventoryInSectionShare)
) )
, withSelectedSection ( , withSelectedSection (
\mid c2d -> let focusedShare = sdsFocus (mid, c2d) devicesInSectionShare \mid c2d -> let focusedShare = sdsFocus (mid, c2d) devicesInSectionShare
......
...@@ -420,7 +420,7 @@ updateMapStatus mode ...@@ -420,7 +420,7 @@ updateMapStatus mode
Value x _ -> Just x Value x _ -> Just x
_ -> Nothing) sharedMapAction */ _ -> Nothing) sharedMapAction */
(Title "Map Status" @>> updateInformationWithShared (Title "Map Status" @>> updateInformationWithShared
[UpdateSharedUsing id (const snd) const editor] [UpdateSharedUsing id (const snd) (const o Just) editor]
(disabledSections |*| maps2DShare |*| lockedExitsShare |*| lockedHopsShare |*| myInventoryMap |*| myStatusMap |*| sectionUsersShare |*| myUserActorMap |*| myNetwork |*| myDevices) (disabledSections |*| maps2DShare |*| lockedExitsShare |*| lockedHopsShare |*| myInventoryMap |*| myStatusMap |*| sectionUsersShare |*| myUserActorMap |*| myNetwork |*| myDevices)
NoAction) NoAction)
where where
...@@ -437,7 +437,7 @@ disabledSections = sharedStore "disabledSections" 'DS'.newSet ...@@ -437,7 +437,7 @@ disabledSections = sharedStore "disabledSections" 'DS'.newSet
updateSectionStatus :: !Coord3D -> Task (MapAction SectionStatus) updateSectionStatus :: !Coord3D -> Task (MapAction SectionStatus)
updateSectionStatus c3d=:(floorIdx, _) updateSectionStatus c3d=:(floorIdx, _)
= Title "Section Status" @>> updateInformationWithShared = Title "Section Status" @>> updateInformationWithShared
[UpdateSharedUsing id (const snd) const editor] [UpdateSharedUsing id (const snd) (const o Just) editor]
(maps2DShare |*| lockedExitsShare |*| lockedHopsShare |*| sdsFocus c3d inventoryInSectionShare |*| sdsFocus c3d statusInSectionShare |*| sdsFocus c3d (actorsInSectionShare myUserActorMap) |*| myNetwork |*| myDevices) (maps2DShare |*| lockedExitsShare |*| lockedHopsShare |*| sdsFocus c3d inventoryInSectionShare |*| sdsFocus c3d statusInSectionShare |*| sdsFocus c3d (actorsInSectionShare myUserActorMap) |*| myNetwork |*| myDevices)
NoAction NoAction
where where
......
...@@ -80,7 +80,7 @@ periodicallyUpdateEntity :: !Int -> Task () ...@@ -80,7 +80,7 @@ periodicallyUpdateEntity :: !Int -> Task ()
periodicallyUpdateEntity n = updateEntity n moveEntity // TODO FIXME PERFORMANCE doTaskPeriodically 1 (updateEntity n moveEntity) <<@ NoUserInterface periodicallyUpdateEntity n = updateEntity n moveEntity // TODO FIXME PERFORMANCE doTaskPeriodically 1 (updateEntity n moveEntity) <<@ NoUserInterface
mapView` :: User [Entity] -> Task () mapView` :: User [Entity] -> Task ()
mapView` currentUser es = (updateSharedInformation [UpdateSharedAs toMap fromMap const] (userMapState currentUser >*< entityMap) @! ()) mapView` currentUser es = (updateSharedInformation [UpdateSharedAs toMap fromMap (const o Just)] (userMapState currentUser >*< entityMap) @! ())
where where
toMap :: (MapState, EntityMap) -> LeafletMap toMap :: (MapState, EntityMap) -> LeafletMap
toMap ({MapState | perspective}, markers) toMap ({MapState | perspective}, markers)
...@@ -106,7 +106,7 @@ mapView` currentUser es = (updateSharedInformation [UpdateSharedAs toMap fromMap ...@@ -106,7 +106,7 @@ mapView` currentUser es = (updateSharedInformation [UpdateSharedAs toMap fromMap
mapView :: (sds () r w) (r -> Bool) User [Entity] -> Task () | iTask r & iTask w & RWShared sds mapView :: (sds () r w) (r -> Bool) User [Entity] -> Task () | iTask r & iTask w & RWShared sds
mapView sh radarWorks currentUser es = (updateSharedInformation [UpdateSharedAs toMap fromMap const] (mapState >*| sh) @! ()) mapView sh radarWorks currentUser es = (updateSharedInformation [UpdateSharedAs toMap fromMap (const o Just)] (mapState >*| sh) @! ())
where where
toMap ({perspective, entities = markers}, shval) toMap ({perspective, entities = markers}, shval)
= toLeafletMap { ContactMap = toLeafletMap { ContactMap
......
...@@ -23,5 +23,5 @@ where ...@@ -23,5 +23,5 @@ where
>>= \result -> Hint "Result:" @>> viewInformation [] result >>= \result -> Hint "Result:" @>> viewInformation [] result
>>= return >>= return
noteEditor = UpdateSharedUsing id (const id) const textArea noteEditor = UpdateSharedUsing id (const id) (const o Just) textArea
listEditor = UpdateSharedAs (split "\n") (\_ l -> join "\n" l) const listEditor = UpdateSharedAs (split "\n") (\_ l -> join "\n" l) (const o Just)
...@@ -20,11 +20,10 @@ sharedNotes ...@@ -20,11 +20,10 @@ sharedNotes
(Hint "View on note" @>> viewSharedInformation [ViewUsing id textArea] note) (Hint "View on note" @>> viewSharedInformation [ViewUsing id textArea] note)
-||- -||-
// an editor to update the shared string // an editor to update the shared string
((Hint "Update shared note 1" @>> updateSharedInformation [UpdateSharedUsing id (const id) const textArea] note) ((Hint "Update shared note 1" @>> updateSharedInformation [UpdateSharedUsing id (const id) (const o Just) textArea] note)
-||- -||-
// and an other updating editor // and an other updating editor
(Hint "Update shared note 2" @>> updateSharedInformation [UpdateSharedUsing id (const id) const textArea] note) (Hint "Update shared note 2" @>> updateSharedInformation [UpdateSharedUsing id (const id) (const o Just) textArea] note)
) <<@ ArrangeHorizontal ) <<@ ArrangeHorizontal
) )
>>= \result -> Hint "Resulting string is:" @>> viewInformation [ViewUsing id textArea] result >>= \result -> Hint "Resulting string is:" @>> viewInformation [ViewUsing id textArea] result
......
...@@ -34,7 +34,7 @@ editWithStatistics ...@@ -34,7 +34,7 @@ editWithStatistics
editFile :: String (Shared sds String) -> Task () | RWShared sds editFile :: String (Shared sds String) -> Task () | RWShared sds
editFile fileName sharedFile editFile fileName sharedFile
= Hint ("edit " +++ fileName) @>> updateSharedInformation [UpdateSharedUsing id (const id) const textArea] sharedFile @! () = Hint ("edit " +++ fileName) @>> updateSharedInformation [UpdateSharedUsing id (const id) (const o Just) textArea] sharedFile @! ()
showStatistics :: (Shared sds String) -> Task () | RWShared sds showStatistics :: (Shared sds String) -> Task () | RWShared sds
showStatistics sharedFile = Hint "Statistics:" @>> viewSharedInformation [ViewAs stat] sharedFile @! () showStatistics sharedFile = Hint "Statistics:" @>> viewSharedInformation [ViewAs stat] sharedFile @! ()
......
...@@ -20,6 +20,6 @@ calculateSumInRecord ...@@ -20,6 +20,6 @@ calculateSumInRecord
= withShared (0,0) = withShared (0,0)
(\sum -> Title "Sum of 2 numbers, with view" @>> updateSharedInformation (\sum -> Title "Sum of 2 numbers, with view" @>> updateSharedInformation
[UpdateSharedAs (\(i,j) -> {firstNumber = i, secondNumber = j, sum = (i+j)}) [UpdateSharedAs (\(i,j) -> {firstNumber = i, secondNumber = j, sum = (i+j)})
(\_ res -> (res.firstNumber,res.secondNumber)) const] sum (\_ res -> (res.firstNumber,res.secondNumber)) (const o Just)] sum
) )
>>= \(i,j) -> return (i+j) >>= \(i,j) -> return (i+j)
...@@ -14,7 +14,7 @@ playWithMaps = withShared ({defaultValue & icons = shipIcons},defaultValue) (\m ...@@ -14,7 +14,7 @@ playWithMaps = withShared ({defaultValue & icons = shipIcons},defaultValue) (\m
derive gDefault LeafletSimpleState, LeafletObjectID derive gDefault LeafletSimpleState, LeafletObjectID
manipulateMap :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWShared sds manipulateMap :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWShared sds
manipulateMap m = updateSharedInformation [UpdateSharedUsing id (flip const) const (customLeafletEditor eventHandlers defaultValue)] m manipulateMap m = updateSharedInformation [UpdateSharedUsing id (flip const) (const o Just) (customLeafletEditor eventHandlers defaultValue)] m
<<@ ApplyLayout (setUIAttributes (sizeAttr FlexSize FlexSize)) @! () <<@ ApplyLayout (setUIAttributes (sizeAttr FlexSize FlexSize)) @! ()
where where
eventHandlers = {simpleStateEventHandlers & onHtmlEvent = onHtmlEvent} eventHandlers = {simpleStateEventHandlers & onHtmlEvent = onHtmlEvent}
......
implementation module Ligretto.UI implementation module Ligretto.UI
import StdBool, StdEnum, StdList import StdBool, StdEnum, StdList
from StdFunc import id, const from StdFunc import id, const, o
import Data.GenEq import Data.GenEq
import iTasks.WF.Tasks.Interaction import iTasks.WF.Tasks.Interaction
import Graphics.Scalable.Extensions import Graphics.Scalable.Extensions
...@@ -9,14 +9,14 @@ import iTasks.Extensions.SVG.SVGEditor ...@@ -9,14 +9,14 @@ import iTasks.Extensions.SVG.SVGEditor
import Ligretto.UoD import Ligretto.UoD
ligrettoEditor :: !Color -> UpdateSharedOption GameSt GameSt ligrettoEditor :: !Color -> UpdateSharedOption GameSt GameSt
ligrettoEditor me = UpdateSharedUsing id (const id) const (fromSVGEditor ligrettoEditor me = UpdateSharedUsing id (const id) (const o Just) (fromSVGEditor
{ initView = id { initView = id
, renderImage = const (player_perspective me) , renderImage = const (player_perspective me)
, updModel = const id , updModel = const id
}) })
accoladesEditor :: !Color -> UpdateSharedOption GameSt GameSt accoladesEditor :: !Color -> UpdateSharedOption GameSt GameSt
accoladesEditor me = UpdateSharedUsing id (const id) const (fromSVGEditor accoladesEditor me = UpdateSharedUsing id (const id) (const o Just) (fromSVGEditor
{ initView = id { initView = id
, renderImage = const (player_perspective me) , renderImage = const (player_perspective me)
, updModel = const id , updModel = const id
......
implementation module Trax.UI implementation module Trax.UI
import StdBool, StdList import StdBool, StdList
from StdFunc import const, flip, id from StdFunc import const, flip, id, o
from Data.List import lookup from Data.List import lookup
import iTasks.WF.Tasks.Interaction import iTasks.WF.Tasks.Interaction
import iTasks.Extensions.SVG.SVGEditor import iTasks.Extensions.SVG.SVGEditor
...@@ -10,7 +10,7 @@ import Trax.UoD ...@@ -10,7 +10,7 @@ import Trax.UoD
:: RenderMode = ViewMode | PlayMode :: RenderMode = ViewMode | PlayMode
updateTraxEditor :: Bool -> UpdateSharedOption TraxSt TraxSt updateTraxEditor :: Bool -> UpdateSharedOption TraxSt TraxSt
updateTraxEditor turn = UpdateSharedUsing id (const id) const (fromSVGEditor updateTraxEditor turn = UpdateSharedUsing id (const id) (const o Just) (fromSVGEditor
{ initView = id { initView = id
, renderImage = \_ -> toImage PlayMode turn , renderImage = \_ -> toImage PlayMode turn
, updModel = flip const , updModel = flip const
......
...@@ -83,7 +83,7 @@ filterTestsByName pattern tests = filter (\{UnitTest|name} -> indexOf pattern na ...@@ -83,7 +83,7 @@ filterTestsByName pattern tests = filter (\{UnitTest|name} -> indexOf pattern na
//UTILITY TASKS //UTILITY TASKS
testEditor :: (Editor a) (EditMode a) -> Task a | iTask a testEditor :: (Editor a) (EditMode a) -> Task a | iTask a
testEditor editor mode testEditor editor mode
= (interactR unitShare {onInit = const ((),mode), onEdit = \v l -> (l,Nothing), onRefresh = \_ l (Just v) -> (l,v,Nothing)} editor @ snd = (interactR unitShare {onInit = const ((),mode), onEdit = \v l -> (l,Nothing), onRefresh = \_ l v -> (l,v,Nothing)} editor @ snd
>&> \s -> Title "Editor value" @>> viewSharedInformation [ViewAs (toString o toJSON)] s @? tvFromMaybe >&> \s -> Title "Editor value" @>> viewSharedInformation [ViewAs (toString o toJSON)] s @? tvFromMaybe
) <<@ ArrangeHorizontal ) <<@ ArrangeHorizontal
...@@ -94,7 +94,7 @@ testEditorWithShare editor model viewMode = (withShared model ...@@ -94,7 +94,7 @@ testEditorWithShare editor model viewMode = (withShared model
||- ||-
(Title "Editor under test" @>> interactR smodel {onInit = \r -> ((),if viewMode View Update $ r) (Title "Editor under test" @>> interactR smodel {onInit = \r -> ((),if viewMode View Update $ r)
,onEdit = \v l -> (l,Just (\_ -> v)) ,onEdit = \v l -> (l,Just (\_ -> v))
,onRefresh = \r l v -> (l,r,Nothing)} editor @ snd) ,onRefresh = \r l _ -> (l,Just r,Nothing)} editor @ snd)
) <<@ ArrangeHorizontal ) <<@ ArrangeHorizontal
testCommonInteractions :: String -> Task a | iTask, gDefault{|*|} a testCommonInteractions :: String -> Task a | iTask, gDefault{|*|} a
......
...@@ -67,19 +67,17 @@ accWorldOSError :: !(*World -> (MaybeOSError a, *World)) -> Task a | ...@@ -67,19 +67,17 @@ accWorldOSError :: !(*World -> (MaybeOSError a, *World)) -> Task a |
:: OSException = OSException !OSError :: OSException = OSException !OSError
instance toString OSException instance toString OSException
/**
* Core interaction task. All other interaction tasks are derived from this one.
* There are two almost identical versions:
* The `interactRW` version can update the given sds.
* The `interactR` version only reads, which means it can also be used for sds's that are not writable.
*/
:: InteractionHandlers l r w v = :: InteractionHandlers l r w v =
{ onInit :: !(r -> (l, EditMode v)) { onInit :: !(r -> (l, EditMode v))
, onEdit :: !(v l -> (l, Maybe (r -> w))) , onEdit :: !(v l -> (l, Maybe (r -> w)))
, onRefresh :: !(r l (Maybe v) -> (l, v, Maybe (r -> w))) , onRefresh :: !(r l (Maybe v) -> (l, Maybe v, Maybe (r -> w)))
} }
//Version which can write shared data /**
* Core interaction task. All other interaction tasks are derived from this
* one. `interactR` is almost identical but does not update the given sds.
*/
interactRW :: !(sds () r w) (InteractionHandlers l r w v) (Editor v) -> Task (l,v) | iTask l & iTask r & iTask v & TC r & TC w & RWShared sds interactRW :: !(sds () r w) (InteractionHandlers l r w v) (Editor v) -> Task (l,v) | iTask l & iTask r & iTask v & TC r & TC w & RWShared sds
//Version which does not write shared data
//* See documentation on `interactRW`.
interactR :: (sds () r w) (InteractionHandlers l r w v) (Editor v) -> Task (l,v) | iTask l & iTask r & iTask v & TC r & TC w & Registrable sds interactR :: (sds () r w) (InteractionHandlers l r w v) (Editor v) -> Task (l,v) | iTask l & iTask r & iTask v & TC r & TC w & Registrable sds
...@@ -151,11 +151,15 @@ evalInteract l v mst mode sds handlers editor writefun ResetEvent evalOpts=:{tas ...@@ -151,11 +151,15 @@ evalInteract l v mst mode sds handlers editor writefun ResetEvent evalOpts=:{tas
, iworld) , iworld)
evalInteract l v mst mode sds handlers editor writefun event=:(RefreshEvent taskIds _) evalOpts=:{taskId,lastEval} iworld evalInteract l v mst mode sds handlers editor writefun event=:(RefreshEvent taskIds _) evalOpts=:{taskId,lastEval} iworld
| isNothing mst = (ExceptionResult (exception "corrupt editor state"), iworld) | isNothing mst = (ExceptionResult (exception "corrupt editor state"), iworld)
# st = fromJust mst
| 'DS'.member taskId taskIds | 'DS'.member taskId taskIds
= readRegisterCompletely sds (maybe NoValue (\v->Value (l, v) False) v) (\e->mkUIIfReset e (asyncSDSLoaderUI Read)) = readRegisterCompletely sds (maybe NoValue (\v->Value (l, v) False) v) (\e->mkUIIfReset e (asyncSDSLoaderUI Read))
(\r event evalOpts iworld (\r event evalOpts iworld
# (l, v, mbf) = handlers.InteractionHandlers.onRefresh r l v # (l, mbV, mbf) = handlers.InteractionHandlers.onRefresh r l v
= case withVSt taskId (editor.Editor.onRefresh [] v (fromJust mst)) iworld of # mbChange = case mbV of
Just v = withVSt taskId (editor.Editor.onRefresh [] v st) iworld
Nothing = (Ok (NoChange, st), iworld)
= case mbChange of
(Error e, iworld) = (ExceptionResult (exception e), iworld) (Error e, iworld) = (ExceptionResult (exception e), iworld)
(Ok (change, st), iworld) (Ok (change, st), iworld)
# v = editor.Editor.valueFromState st # v = editor.Editor.valueFromState st
......
...@@ -20,16 +20,20 @@ from Data.Functor import class Functor ...@@ -20,16 +20,20 @@ from Data.Functor import class Functor
= E.v: UpdateAs (a -> v) (a v -> a) & iTask v = E.v: UpdateAs (a -> v) (a v -> a) & iTask v
| E.v: UpdateUsing (a -> v) (a v -> a) (Editor v) & iTask v | E.v: UpdateUsing (a -> v) (a v -> a) (Editor v) & iTask v
//When using an shared data you have to supply an additional /**
//conflict resolution function (v v -> v) * When using an shared data you have to supply an additional conflict
//When both the view has been edited, and the sds has changed, this * resolution function `(v (Maybe v) -> Maybe v)`. When both the view has been
//function determines what the new view should be. * edited, and the sds has changed, this function determines what the new view
//The first argument is the new view as computed from the changed sds, * should be.
//and the second argument is the edited view by the user. * The first argument is the new view as computed from the changed sds, and the
* second argument is the edited view by the user, if the current view
* represents a valid value.
* If the result is `Nothing` the view is not updated.
*/
:: UpdateSharedOption a b :: UpdateSharedOption a b
= E.v: UpdateSharedAs (a -> v) (a v -> b) (v v -> v) & iTask v = E.v: UpdateSharedAs (a -> v) (a v -> b) (v (Maybe v) -> Maybe v) & iTask v
| E.v: UpdateSharedUsing (a -> v) (a v -> b) (v v -> v) (Editor v) & iTask v | E.v: UpdateSharedUsing (a -> v) (a v -> b) (v (Maybe v) -> Maybe v) (Editor v) & iTask v
| E.v: UpdateSharedUsingAuto (a -> Maybe v) (a v -> b) (v v -> v) (Editor v) & iTask v | E.v: UpdateSharedUsingAuto (a -> Maybe v) (a v -> b) (v (Maybe v) -> Maybe v) (Editor v) & iTask v
//Selection in arbitrary containers (explicit identification is needed) //Selection in arbitrary containers (explicit identification is needed)
:: SelectOption c s :: SelectOption c s
......
...@@ -52,7 +52,7 @@ updateSharedEditor :: [UpdateSharedOption r w] -> UpdateSharedOption r w | iTask ...@@ -52,7 +52,7 @@ updateSharedEditor :: [UpdateSharedOption r w] -> UpdateSharedOption r w | iTask
updateSharedEditor [UpdateSharedUsing tof fromf conflictf editor:_] = UpdateSharedUsing tof fromf conflictf editor updateSharedEditor [UpdateSharedUsing tof fromf conflictf editor:_] = UpdateSharedUsing tof fromf conflictf editor
updateSharedEditor [UpdateSharedAs tof fromf conflictf:_] = UpdateSharedUsing tof fromf conflictf gEditor{|*|} updateSharedEditor [UpdateSharedAs tof fromf conflictf:_] = UpdateSharedUsing tof fromf conflictf gEditor{|*|}
updateSharedEditor [_:es] = updateSharedEditor es updateSharedEditor [_:es] = updateSharedEditor es
updateSharedEditor [] = UpdateSharedUsingAuto dynid (flip const) const gEditor{|*|} updateSharedEditor [] = UpdateSharedUsingAuto dynid (flip const) (const o Just) gEditor{|*|}