...
 
Commits (6)
......@@ -17,7 +17,7 @@ manipulateMap :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWSha
manipulateMap m = updateSharedInformation [UpdateSharedUsing id (flip const) (const o Just) (customLeafletEditor eventHandlers defaultValue)] m
<<@ ApplyLayout (setUIAttributes (sizeAttr FlexSize FlexSize)) @! ()
where
eventHandlers = {simpleStateEventHandlers & onHtmlEvent = onHtmlEvent}
eventHandlers = simpleStateEventHandlers ++ [OnHtmlEvent onHtmlEvent]
onHtmlEvent "closewindows" (l,s) = ({LeafletMap|l & objects = [o \\ o <- l.LeafletMap.objects | not (o =: (Window _))]},s)
onHtmlEvent _ (l,s) = (l,s)
......
......@@ -598,19 +598,24 @@ where
// we have to use the first element to update the type,
// the `b` and `c` type variable is required to be equal for all list elements
args=:[fst: _] =
case (funcs, fst) of
((f, g) :: (a -> b, [b] -> c), _ :: a) = dynamic (g $ fromDynList (dynamic f) args)
_ = abort "corrupt dynamic editor value"
fromDynList :: !Dynamic ![Dynamic] -> [b] | TC b
case funcs of
((f, g) :: (a -> b, [b] -> c)) =
case fromDynList (dynamic f) args of
Just res = dynamic g res
Nothing =
case (funcs, fst) of
((f, g) :: (a -> b, [b] -> c), _ :: a) = dynamic (g $ fromJust $ fromDynList (dynamic f) args)
_ = abort "corrupt dynamic editor value"
_ = abort "corrupt dynamic editor value"
fromDynList :: !Dynamic ![Dynamic] -> Maybe [b] | TC b
fromDynList mapFunc dyns = fromDynList` dyns []
where
fromDynList` [] acc = reverse acc
fromDynList` [] acc = Just $ reverse acc
fromDynList` [dyn : dyns] acc =
case (mapFunc, dyn) of
(mapFunc :: a -> b^, a :: a) = fromDynList` dyns [mapFunc a: acc]
_ = abort "corrupt dynamic editor value"
fromDynList` _ _ = abort "corrupt dynamic editor value"
_ = Nothing
:: E = E.a: E (Editor (DynamicEditorValue a)) & TC a
:: ConsType = Function | List | CustomEditor
......
......@@ -24,7 +24,7 @@ fileCollection :: FileFilter Bool Bool -> SDSSource FilePath FileCollection File
fileCollection rules readOnly deleteRemovedFiles = worldShare (read (matchRules rules)) (write readOnly (matchRules rules)) notify
where
read isFileInCollection dir world = case readDirectory dir world of
(Error (2,msg),world) = (Ok 'DM'.newMap,world) //Directory does not exist yet
(Error (IF_WINDOWS 3 2,msg),world) = (Ok 'DM'.newMap,world) //Directory does not exist yet
(Error (errNo,msg),world) = (Error (toString errNo +++ msg),world)
(Ok files,world) = case (if deleteRemovedFiles (Ok [],world) (readExcludeList dir world)) of
(Error e, world) = (Error e,world)
......@@ -42,7 +42,7 @@ where
# intermediate = isFileInCollection f True
//Read a subcollection
| directory && (decision =: IncludeFile || intermediate =: IncludeFile)
= case read (\p i -> (isFileInCollection (f </> p) i)) (dir </> f) world of
= case read (\p i -> (isFileInCollection (f +++ "/" +++ p) i)) (dir </> f) world of
(Error e,world) = (Error e,world)
(Ok fcollection,world) = case readFiles isFileInCollection excludes dir fs world of
(Error e,world) = (Error e,world)
......@@ -79,7 +79,7 @@ where
(Error e,world) = (Error e,world)
(Ok newfiles,world) = cleanupRemovedFiles curfiles newfiles isFileInCollection dir world
//The directory does not exist yet, create it first and then write the collection
(Error (2,_),world) = case ensureDirectory dir world of
(Error (IF_WINDOWS 3 2,_),world) = case ensureDirectory dir world of
(Error e,world) = (Error e,world)
(Ok (),world) = case writeFiles ('DM'.toList collection) isFileInCollection dir world of
(Error e,world) = (Error e,world)
......@@ -104,7 +104,7 @@ where
= writeFiles fs isFileInCollection dir world
| otherwise = case ensureDirectory (dir </> name) world of
(Error e,world) = (Error e,world)
(Ok (),world) = case write False (\p i -> isFileInCollection (name </> p) i) (dir </> name) collection world of
(Ok (),world) = case write False (\p i -> isFileInCollection (name +++ "/" +++ p) i) (dir </> name) collection world of
(Error e,world) = (Error e,world)
(Ok (),world) = case writeFiles fs isFileInCollection dir world of
(Error e,world) = (Error e,world)
......
......@@ -124,11 +124,13 @@ leafletObjectIdOf :: !LeafletObject -> LeafletObjectID
:: LeafletWindowPos = { x :: !Int, y :: !Int }
//Event handlers allow the customization of the map editor behaviour
:: LeafletEventHandlers s =
{ onMapClick :: LeafletLatLng (LeafletMap,s) -> (LeafletMap,s)
, onMarkerClick :: LeafletObjectID (LeafletMap,s) -> (LeafletMap,s)
, onHtmlEvent :: String (LeafletMap,s) -> (LeafletMap,s)
}
:: LeafletEventHandlers s :== [LeafletEventHandler s]
:: LeafletEventHandler s
= OnMapClick (LeafletLatLng (LeafletMap,s) -> (LeafletMap,s))
| OnMapDblClick (LeafletLatLng (LeafletMap,s) -> (LeafletMap,s))
| OnMarkerClick (LeafletObjectID (LeafletMap,s) -> (LeafletMap,s))
| OnHtmlEvent (String (LeafletMap,s) -> (LeafletMap,s))
//A minimal state for tracking a set of selected markers
//and the last place that the map was clicked
......
......@@ -51,6 +51,7 @@ leafletObjectIdOf (Window w) = w.windowId
| LDUpdateObject !LeafletObjectID !LeafletObjectUpdate
//Events
| LDMapClick !LeafletLatLng
| LDMapDblClick !LeafletLatLng
| LDMarkerClick !LeafletObjectID
| LDHtmlEvent !String
......@@ -70,10 +71,10 @@ openStreetMapTiles :: String
openStreetMapTiles = "http://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png"
leafletEditor :: Editor LeafletMap
leafletEditor = leafEditorToEditor leafletEditor`
leafletEditor = leafEditorToEditor (leafletEditor` (const id))
leafletEditor` :: LeafEditor [LeafletEdit] LeafletMap LeafletMap
leafletEditor` =
leafletEditor` :: !(JSVal *JSWorld -> *JSWorld) -> LeafEditor [LeafletEdit] LeafletMap LeafletMap
leafletEditor` postInitUI =
{ LeafEditor
| genUI = withClientSideInit initUI genUI
, onEdit = onEdit
......@@ -186,13 +187,16 @@ where
True
= world
False
# (cb,world) = jsWrapFun (\a w -> onMapDragEnd me a w) me world
# (cb,world) = jsWrapFun (onMapDragEnd me) me world
# world = (mapObj .# "addEventListener" .$! ("dragend",cb)) world
# (cb,world) = jsWrapFun (\a w -> onMapZoomEnd me a w) me world
# (cb,world) = jsWrapFun (onMapZoomEnd me) me world
# world = (mapObj .# "addEventListener" .$! ("zoomend",cb)) world
# (cb,world) = jsWrapFun (\a w -> onMapClick me a w) me world
# (cb,world) = jsWrapFun (onMapClick False me) me world
# world = (mapObj .# "addEventListener" .$! ("click",cb)) world
# (cb,world) = jsWrapFun (onMapClick True me) me world
# world = (mapObj .# "addEventListener" .$! ("dblclick",cb)) world
= world
# world = postInitUI mapObj world
= world
onResize me world
......@@ -225,13 +229,13 @@ where
# world = (me .# "doEditEvent" .$! (taskId,editorId,edit)) world
= world
onMapClick me args world
onMapClick double me args world
# (taskId,world) = me .# "attributes.taskId" .? world
# (editorId,world) = me .# "attributes.editorId" .? world
# (mapObj,world) = args.[0] .# "target" .? world
# (clickPos,world) = args.[0] .# "latlng" .? world
# (position,world) = toLatLng clickPos world
# edit = toJSON [LDMapClick position]
# edit = toJSON [if double LDMapDblClick LDMapClick position]
# world = (me .# "doEditEvent" .$! (taskId,editorId,edit)) world
= world
......@@ -703,10 +707,9 @@ gEq{|LeafletLatLng|} x y = (toString x.lat == toString y.lat) && (toString x.lng
simpleStateEventHandlers :: LeafletEventHandlers LeafletSimpleState
simpleStateEventHandlers =
{ onMapClick = \position (l,s) -> (addCursorMarker position l,{LeafletSimpleState|s & cursor = Just position})
, onMarkerClick = \markerId (l,s) -> (l,{LeafletSimpleState|s & selection = toggle markerId s.LeafletSimpleState.selection})
, onHtmlEvent = \msg (l,s) -> (l,s)
}
[ OnMapClick \position (l,s) -> (addCursorMarker position l,{LeafletSimpleState|s & cursor = Just position})
, OnMarkerClick \markerId (l,s) -> (l,{LeafletSimpleState|s & selection = toggle markerId s.LeafletSimpleState.selection})
]
where
addCursorMarker position l=:{LeafletMap|objects,icons} = {l & objects = addCursorObject objects, icons=addCursorIcon icons}
where
......@@ -742,36 +745,41 @@ customLeafletEditor` handlers initial =
, valueFromState = valueFromState
}
where
genUI attributes datapath mode vst = case leafletEditor`.LeafEditor.genUI attributes datapath (mapEditMode fst mode) vst of
baseEditor = leafletEditor` case [h \\ OnMapDblClick h <- handlers] of
[_:_] -> \me -> me .# "doubleClickZoom" .# "disable" .$! ()
[] -> const id
genUI attributes datapath mode vst = case baseEditor.LeafEditor.genUI attributes datapath (mapEditMode fst mode) vst of
(Error e, vst) = (Error e, vst)
(Ok (ui,mapState),vst) = (Ok (ui,(mapState, initial)),vst)
onEdit datapath edit (mapState,customState) vst = case leafletEditor`.LeafEditor.onEdit datapath edit mapState vst of
onEdit datapath edit (mapState,customState) vst = case baseEditor.LeafEditor.onEdit datapath edit mapState vst of
(Error e, vst) = (Error e, vst)
(Ok (mapChange,mapState), vst)
//Apply event handlers
# (newMapState,customState) = updateCustomState handlers datapath edit (mapState,customState)
//Determine the change to the map
= case leafletEditor`.LeafEditor.onRefresh datapath newMapState mapState vst of
= case baseEditor.LeafEditor.onRefresh datapath newMapState mapState vst of
(Error e, vst) = (Error e, vst)
(Ok (mapRefreshChange,mapState),vst)
= (Ok (mergeUIChanges mapChange mapRefreshChange, (mapState,customState)),vst)
onRefresh datapath (newMapState,newCustomState) (curMapState,curCustomState) vst
= case leafletEditor`.LeafEditor.onRefresh datapath newMapState curMapState vst of
= case baseEditor.LeafEditor.onRefresh datapath newMapState curMapState vst of
(Error e, vst) = (Error e, vst)
(Ok (mapChange,mapState),vst) = (Ok (mapChange,(mapState,newCustomState)),vst)
valueFromState s = Just s
updateCustomState {onMapClick,onMarkerClick,onHtmlEvent} datapath (target,edits) state
updateCustomState handlers datapath (target,edits) state
| target <> datapath = state
| otherwise = foldl update state edits
| otherwise = foldl (\s e -> foldl (update e) s handlers) state edits
where
update state (LDMapClick position) = onMapClick position state
update state (LDMarkerClick markerId) = onMarkerClick markerId state
update state (LDHtmlEvent event) = onHtmlEvent event state
update state _ = state
update (LDMapClick position) state (OnMapClick f) = f position state
update (LDMapDblClick position) state (OnMapDblClick f) = f position state
update (LDMarkerClick markerId) state (OnMarkerClick f) = f markerId state
update (LDHtmlEvent event) state (OnHtmlEvent f) = f event state
update _ state _ = state
instance == LeafletObjectID where (==) (LeafletObjectID x) (LeafletObjectID y) = x == y
instance == LeafletIconID where (==) (LeafletIconID x) (LeafletIconID y) = x == y
......
......@@ -56,11 +56,7 @@ where
| if (lastIO =:(Just _))
(tNow - fromJust lastIO > options.EngineOptions.sessionTime)
((build <> appVersion) || (tNow - createdAt > options.EngineOptions.sessionTime))
# (e,iworld) = deleteTaskInstance instanceNo iworld
| e=:(Error _) = (e,iworld)
# (e,iworld) = modify (\output -> del instanceNo output) taskOutput EmptyContext iworld
| e=:(Error _) = (liftError e,iworld)
= (Ok (),iworld)
= deleteTaskInstance instanceNo iworld
| otherwise
= (Ok (), iworld)
......
......@@ -52,10 +52,10 @@ processEvents max iworld
evalTaskInstance :: !InstanceNo !Event !*IWorld -> (!MaybeErrorString (TaskValue DeferredJSON),!*IWorld)
evalTaskInstance instanceNo event iworld
# iworld = mbResetUIState instanceNo event iworld
# (res,iworld) = evalTaskInstance` instanceNo event (event =: DestroyEvent) iworld
# (res,iworld) = evalTaskInstance` instanceNo event iworld
= (res,iworld)
where
evalTaskInstance` instanceNo event destroy iworld=:{clock,current}
evalTaskInstance` instanceNo event iworld=:{current}
// Read the task reduct. If it does not exist, the task has been deleted.
# (curReduct, iworld) = 'SDS'.read (sdsFocus instanceNo taskInstanceTask) EmptyContext iworld
| isError curReduct = exitWithException instanceNo ((\(Error (e,msg)) -> msg) curReduct) iworld
......@@ -82,32 +82,23 @@ where
, nextTaskNo = nextTaskNo
}}
//Apply task's eval function and take updated nextTaskId from iworld
# (newResult,iworld=:{current}) = eval event {mkEvalOpts & lastEval=nextTaskTime, taskId=taskId} iworld
//the 'nextTaskNo' is possibly incremented during evaluation and we need to store it
# (newResult,iworld=:{current=current=:{TaskEvalState|nextTaskNo}})
= eval event {mkEvalOpts & lastEval=nextTaskTime, taskId=taskId} iworld
# newTask = case newResult of
(ValueResult _ _ _ newTask) = newTask
_ = Task eval
# newValue = case newResult of
ValueResult val _ _ _ = val
ExceptionResult (e,str) = NoValue
DestroyedResult = NoValue
# destroyed = newResult =: DestroyedResult
//Reset necessary 'current' values in iworld
# iworld = {IWorld|iworld & current = {TaskEvalState|current & taskInstance = 0}}
// Write the updated progress
# (nextTaskNo,iworld) = getNextTaskNo iworld
//Write the updated state, or cleanup
# (mbErr,iworld) = if destroyed
(Ok (),iworld) //Only update progress when something changed
(case (modify (updateProgress clock newResult nextTaskNo nextTaskTime) (sdsFocus (instanceNo,False,True) taskInstance) EmptyContext iworld) of
(Error e, iworld) = (Error e, iworld)
(Ok _, iworld) = (Ok (), iworld) )
| mbErr=:(Error _)
# (Error (_,description)) = mbErr
= exitWithException instanceNo description iworld
//Store or remove reduct
# (nextTaskNo,iworld) = getNextTaskNo iworld
# (_,iworld) = write newTask (sdsFocus instanceNo taskInstanceTask) EmptyContext iworld
//Store or delete value
# newValue = case newResult of
ValueResult val _ _ _ = val //Just (TIValue val)
ExceptionResult (e,str) = NoValue //Just (TIException e str)
DestroyedResult = NoValue //Nothing
# (mbErr,iworld) = write newValue (sdsFocus instanceNo taskInstanceValue) EmptyContext iworld
(cleanupTaskState instanceNo iworld)
(updateTaskState instanceNo newResult newTask newValue nextTaskNo nextTaskTime iworld)
| mbErr=:(Error _)
# (Error (_,description)) = mbErr
= exitWithException instanceNo description iworld
......@@ -127,6 +118,27 @@ where
DestroyedResult
= (Ok NoValue, iworld)
updateTaskState instanceNo newResult newTask newValue nextTaskNo nextTaskTime iworld=:{clock}
//Store progress
# (mbErr,iworld) = modify (updateProgress clock newResult nextTaskNo nextTaskTime) (sdsFocus (instanceNo,False,True) taskInstance) EmptyContext iworld
| mbErr =: (Error _) = (liftError mbErr, iworld)
//Store reduct
# (mbErr,iworld) = write newTask (sdsFocus instanceNo taskInstanceTask) EmptyContext iworld
| mbErr =: (Error _) = (liftError mbErr, iworld)
//Store value
# (mbErr,iworld) = write newValue (sdsFocus instanceNo taskInstanceValue) EmptyContext iworld
| mbErr =: (Error _) = (liftError mbErr, iworld)
= (Ok (),iworld)
cleanupTaskState instanceNo iworld
//Remove local shares
# (mbErr,iworld) = write Nothing (sdsFocus instanceNo taskInstanceShares) EmptyContext iworld
| mbErr =: (Error _) = (liftError mbErr, iworld)
//Remove residual queued output
# (mbErr,iworld) = modify (\output -> 'DM'.del instanceNo output) taskOutput EmptyContext iworld
| mbErr =: (Error _) = (liftError mbErr, iworld)
= (Ok (),iworld)
exitWithException instanceNo description iworld
# iworld = queueException instanceNo description iworld
= (Error description, iworld)
......@@ -142,8 +154,6 @@ where
| isError meta = ({defaultValue & nextTaskNo=1, nextTaskTime=1},iworld)
= (directResult (fromOk meta),iworld)
getNextTaskNo iworld=:{IWorld|current={TaskEvalState|nextTaskNo}} = (nextTaskNo,iworld)
updateProgress now result nextTaskNo nextTaskTime meta
# attachedTo = case meta.TaskMeta.attachedTo of //Release temporary attachment after first evaluation
(Just (_,[])) = Nothing
......