...
 
Commits (2)
...@@ -17,7 +17,7 @@ manipulateMap :: (Shared sds (LeafletMap,LeafletSimpleState)) -> Task () | RWSha ...@@ -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 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]
onHtmlEvent "closewindows" (l,s) = ({LeafletMap|l & objects = [o \\ o <- l.LeafletMap.objects | not (o =: (Window _))]},s) onHtmlEvent "closewindows" (l,s) = ({LeafletMap|l & objects = [o \\ o <- l.LeafletMap.objects | not (o =: (Window _))]},s)
onHtmlEvent _ (l,s) = (l,s) onHtmlEvent _ (l,s) = (l,s)
......
...@@ -124,11 +124,13 @@ leafletObjectIdOf :: !LeafletObject -> LeafletObjectID ...@@ -124,11 +124,13 @@ leafletObjectIdOf :: !LeafletObject -> LeafletObjectID
:: LeafletWindowPos = { x :: !Int, y :: !Int } :: LeafletWindowPos = { x :: !Int, y :: !Int }
//Event handlers allow the customization of the map editor behaviour //Event handlers allow the customization of the map editor behaviour
:: LeafletEventHandlers s = :: LeafletEventHandlers s :== [LeafletEventHandler s]
{ onMapClick :: LeafletLatLng (LeafletMap,s) -> (LeafletMap,s)
, onMarkerClick :: LeafletObjectID (LeafletMap,s) -> (LeafletMap,s) :: LeafletEventHandler s
, onHtmlEvent :: String (LeafletMap,s) -> (LeafletMap,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 //A minimal state for tracking a set of selected markers
//and the last place that the map was clicked //and the last place that the map was clicked
......
...@@ -51,6 +51,7 @@ leafletObjectIdOf (Window w) = w.windowId ...@@ -51,6 +51,7 @@ leafletObjectIdOf (Window w) = w.windowId
| LDUpdateObject !LeafletObjectID !LeafletObjectUpdate | LDUpdateObject !LeafletObjectID !LeafletObjectUpdate
//Events //Events
| LDMapClick !LeafletLatLng | LDMapClick !LeafletLatLng
| LDMapDblClick !LeafletLatLng
| LDMarkerClick !LeafletObjectID | LDMarkerClick !LeafletObjectID
| LDHtmlEvent !String | LDHtmlEvent !String
...@@ -70,10 +71,10 @@ openStreetMapTiles :: String ...@@ -70,10 +71,10 @@ openStreetMapTiles :: String
openStreetMapTiles = "http://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png" openStreetMapTiles = "http://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png"
leafletEditor :: Editor LeafletMap leafletEditor :: Editor LeafletMap
leafletEditor = leafEditorToEditor leafletEditor` leafletEditor = leafEditorToEditor (leafletEditor` (const id))
leafletEditor` :: LeafEditor [LeafletEdit] LeafletMap LeafletMap leafletEditor` :: !(JSVal *JSWorld -> *JSWorld) -> LeafEditor [LeafletEdit] LeafletMap LeafletMap
leafletEditor` = leafletEditor` postInitUI =
{ LeafEditor { LeafEditor
| genUI = withClientSideInit initUI genUI | genUI = withClientSideInit initUI genUI
, onEdit = onEdit , onEdit = onEdit
...@@ -186,13 +187,16 @@ where ...@@ -186,13 +187,16 @@ where
True True
= world = world
False 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 # 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 # 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 # world = (mapObj .# "addEventListener" .$! ("click",cb)) world
# (cb,world) = jsWrapFun (onMapClick True me) me world
# world = (mapObj .# "addEventListener" .$! ("dblclick",cb)) world
= world = world
# world = postInitUI mapObj world
= world = world
onResize me world onResize me world
...@@ -225,13 +229,13 @@ where ...@@ -225,13 +229,13 @@ where
# world = (me .# "doEditEvent" .$! (taskId,editorId,edit)) world # world = (me .# "doEditEvent" .$! (taskId,editorId,edit)) world
= world = world
onMapClick me args world onMapClick double me args world
# (taskId,world) = me .# "attributes.taskId" .? world # (taskId,world) = me .# "attributes.taskId" .? world
# (editorId,world) = me .# "attributes.editorId" .? world # (editorId,world) = me .# "attributes.editorId" .? world
# (mapObj,world) = args.[0] .# "target" .? world # (mapObj,world) = args.[0] .# "target" .? world
# (clickPos,world) = args.[0] .# "latlng" .? world # (clickPos,world) = args.[0] .# "latlng" .? world
# (position,world) = toLatLng clickPos 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 = (me .# "doEditEvent" .$! (taskId,editorId,edit)) world
= world = world
...@@ -703,10 +707,9 @@ gEq{|LeafletLatLng|} x y = (toString x.lat == toString y.lat) && (toString x.lng ...@@ -703,10 +707,9 @@ gEq{|LeafletLatLng|} x y = (toString x.lat == toString y.lat) && (toString x.lng
simpleStateEventHandlers :: LeafletEventHandlers LeafletSimpleState simpleStateEventHandlers :: LeafletEventHandlers LeafletSimpleState
simpleStateEventHandlers = simpleStateEventHandlers =
{ onMapClick = \position (l,s) -> (addCursorMarker position l,{LeafletSimpleState|s & cursor = Just position}) [ 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}) , OnMarkerClick \markerId (l,s) -> (l,{LeafletSimpleState|s & selection = toggle markerId s.LeafletSimpleState.selection})
, onHtmlEvent = \msg (l,s) -> (l,s) ]
}
where where
addCursorMarker position l=:{LeafletMap|objects,icons} = {l & objects = addCursorObject objects, icons=addCursorIcon icons} addCursorMarker position l=:{LeafletMap|objects,icons} = {l & objects = addCursorObject objects, icons=addCursorIcon icons}
where where
...@@ -742,36 +745,41 @@ customLeafletEditor` handlers initial = ...@@ -742,36 +745,41 @@ customLeafletEditor` handlers initial =
, valueFromState = valueFromState , valueFromState = valueFromState
} }
where 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) (Error e, vst) = (Error e, vst)
(Ok (ui,mapState),vst) = (Ok (ui,(mapState, initial)),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) (Error e, vst) = (Error e, vst)
(Ok (mapChange,mapState), vst) (Ok (mapChange,mapState), vst)
//Apply event handlers //Apply event handlers
# (newMapState,customState) = updateCustomState handlers datapath edit (mapState,customState) # (newMapState,customState) = updateCustomState handlers datapath edit (mapState,customState)
//Determine the change to the map //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) (Error e, vst) = (Error e, vst)
(Ok (mapRefreshChange,mapState),vst) (Ok (mapRefreshChange,mapState),vst)
= (Ok (mergeUIChanges mapChange mapRefreshChange, (mapState,customState)),vst) = (Ok (mergeUIChanges mapChange mapRefreshChange, (mapState,customState)),vst)
onRefresh datapath (newMapState,newCustomState) (curMapState,curCustomState) 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) (Error e, vst) = (Error e, vst)
(Ok (mapChange,mapState),vst) = (Ok (mapChange,(mapState,newCustomState)),vst) (Ok (mapChange,mapState),vst) = (Ok (mapChange,(mapState,newCustomState)),vst)
valueFromState s = Just s valueFromState s = Just s
updateCustomState {onMapClick,onMarkerClick,onHtmlEvent} datapath (target,edits) state updateCustomState handlers datapath (target,edits) state
| target <> datapath = state | target <> datapath = state
| otherwise = foldl update state edits | otherwise = foldl (\s e -> foldl (update e) s handlers) state edits
where where
update state (LDMapClick position) = onMapClick position state update (LDMapClick position) state (OnMapClick f) = f position state
update state (LDMarkerClick markerId) = onMarkerClick markerId state update (LDMapDblClick position) state (OnMapDblClick f) = f position state
update state (LDHtmlEvent event) = onHtmlEvent event state update (LDMarkerClick markerId) state (OnMarkerClick f) = f markerId state
update state _ = state update (LDHtmlEvent event) state (OnHtmlEvent f) = f event state
update _ state _ = state
instance == LeafletObjectID where (==) (LeafletObjectID x) (LeafletObjectID y) = x == y instance == LeafletObjectID where (==) (LeafletObjectID x) (LeafletObjectID y) = x == y
instance == LeafletIconID where (==) (LeafletIconID x) (LeafletIconID y) = x == y instance == LeafletIconID where (==) (LeafletIconID x) (LeafletIconID y) = x == y
......