Commit 353e64db authored by Bas Lijnse's avatar Bas Lijnse

Merge branch 'master' into 259-editors-need-refinement

parents 47e4f146 bbe0706e
...@@ -71,7 +71,7 @@ toLeafletPerspective :: ContactMapPerspective -> LeafletPerspective ...@@ -71,7 +71,7 @@ toLeafletPerspective :: ContactMapPerspective -> LeafletPerspective
fromLeafletMap :: ContactMap LeafletMap -> ContactMap fromLeafletMap :: ContactMap LeafletMap -> ContactMap
fromLeafletPerspective :: LeafletPerspective -> ContactMapPerspective fromLeafletPerspective :: LeafletPerspective -> ContactMapPerspective
selectionFromLeafletMap :: LeafletMap -> [String] selectionFromLeafletMap :: LeafletMap -> [LeafletObjectID]
//Standard layers available to use in all map views //Standard layers available to use in all map views
standardPerspective :: Shared ContactMapPerspective standardPerspective :: Shared ContactMapPerspective
......
...@@ -215,8 +215,9 @@ where ...@@ -215,8 +215,9 @@ where
fromLeafletLayer cl ll = cl fromLeafletLayer cl ll = cl
*/ */
selectionFromLeafletMap :: LeafletMap -> [String] selectionFromLeafletMap :: LeafletMap -> [LeafletObjectID]
selectionFromLeafletMap {LeafletMap|objects} = [markerId \\ Marker {LeafletMarker|markerId,selected} <- objects | selected] selectionFromLeafletMap {LeafletMap|objects} =
[markerId \\ Marker {LeafletMarker|markerId,selected} <- objects | selected]
fromLeafletLatLng :: !LeafletLatLng -> (!Real,!Real) fromLeafletLatLng :: !LeafletLatLng -> (!Real,!Real)
fromLeafletLatLng {LeafletLatLng|lat,lng} = (lat,lng) fromLeafletLatLng {LeafletLatLng|lat,lng} = (lat,lng)
......
...@@ -605,7 +605,7 @@ where ...@@ -605,7 +605,7 @@ where
isSelected _ _ = False isSelected _ _ = False
updateSelection [] = Nothing updateSelection [] = Nothing
updateSelection [markerId:ms] updateSelection [LeafletObjectID markerId:ms]
| startsWith "c" markerId = Just (Left (toInt (subString 1 (textSize markerId) markerId))) | startsWith "c" markerId = Just (Left (toInt (subString 1 (textSize markerId) markerId)))
| startsWith "a" markerId = Just (Right (toInt (subString 1 (textSize markerId) markerId))) | startsWith "a" markerId = Just (Right (toInt (subString 1 (textSize markerId) markerId)))
= updateSelection ms = updateSelection ms
......
...@@ -117,9 +117,9 @@ toLeafletMap {ContactMap|perspective,markers} ...@@ -117,9 +117,9 @@ toLeafletMap {ContactMap|perspective,markers}
where where
convMarkers markers = [conv m \\ m=:{ContactMapMarker|position} <- markers] convMarkers markers = [conv m \\ m=:{ContactMapMarker|position} <- markers]
conv {ContactMapMarker|markerId,title,position,heading,type,selected} conv {ContactMapMarker|markerId,title,position,heading,type,selected}
= Marker {LeafletMarker|markerId = markerId, title = title, position = toLeafletLatLng position, icon = fmap (\t -> iconIndex heading t selected) type, selected = selected, popup = Nothing} = Marker {LeafletMarker|markerId = LeafletObjectID markerId, title = title, position = toLeafletLatLng position, icon = fmap (\t -> LeafletIconID (iconIndex heading t selected)) type, selected = selected, popup = Nothing}
icon i = {LeafletIcon|iconId=toString i,iconUrl ="/ship-icons/"+++toString i+++".png",iconSize=(24,24)} icon i = {LeafletIcon|iconId=LeafletIconID (toString i),iconUrl ="/ship-icons/"+++toString i+++".png",iconSize=(24,24)}
iconIndex heading type selected = toString (cat type + ( (maybe 24 (\d -> toInt d / 15) heading) + (if selected 25 0)) * 5) iconIndex heading type selected = toString (cat type + ( (maybe 24 (\d -> toInt d / 15) heading) + (if selected 25 0)) * 5)
toLeafletPerspective :: ContactMapPerspective -> LeafletPerspective toLeafletPerspective :: ContactMapPerspective -> LeafletPerspective
...@@ -139,7 +139,7 @@ fromLeafletMap {LeafletMap|perspective,objects} ...@@ -139,7 +139,7 @@ fromLeafletMap {LeafletMap|perspective,objects}
where where
toMarkers objects toMarkers objects
= [{ContactMapMarker|markerId=markerId,title=Nothing,position = fromLeafletLatLng position, type=Nothing,heading=Nothing,selected=selected} = [{ContactMapMarker|markerId=markerId,title=Nothing,position = fromLeafletLatLng position, type=Nothing,heading=Nothing,selected=selected}
\\ Marker {LeafletMarker|markerId,position,selected} <- objects] \\ Marker {LeafletMarker|markerId = LeafletObjectID markerId,position,selected} <- objects]
fromLeafletPerspective :: LeafletPerspective -> ContactMapPerspective fromLeafletPerspective :: LeafletPerspective -> ContactMapPerspective
fromLeafletPerspective {LeafletPerspective|center,cursor,zoom} fromLeafletPerspective {LeafletPerspective|center,cursor,zoom}
......
...@@ -43,7 +43,7 @@ where ...@@ -43,7 +43,7 @@ where
>>- \marker -> upd (\l=:{LeafletMap|objects} -> {LeafletMap|l & objects = objects ++ [marker]}) m >>- \marker -> upd (\l=:{LeafletMap|objects} -> {LeafletMap|l & objects = objects ++ [marker]}) m
toRandomMarker (rLat,rLng) toRandomMarker (rLat,rLng)
= Marker {markerId = markerId, position= {LeafletLatLng|lat = lat, lng = lng}, title = Just markerId, icon = Just icon, selected = False, popup = Nothing} = Marker {markerId = LeafletObjectID markerId, position= {LeafletLatLng|lat = lat, lng = lng}, title = Just markerId, icon = Just icon, selected = False, popup = Nothing}
where where
lat = 52.0 + (toReal (500 + (rLat rem 1000)) / 1000.0) lat = 52.0 + (toReal (500 + (rLat rem 1000)) / 1000.0)
lng = 6.0 + (toReal (500 + (rLng rem 1000)) / 1000.0) lng = 6.0 + (toReal (500 + (rLng rem 1000)) / 1000.0)
...@@ -53,7 +53,7 @@ where ...@@ -53,7 +53,7 @@ where
addMarkerConnectingLine m addMarkerConnectingLine m
= upd (\l=:{LeafletMap|objects} -> {LeafletMap|l & objects = objects ++ [line objects]}) m = upd (\l=:{LeafletMap|objects} -> {LeafletMap|l & objects = objects ++ [line objects]}) m
where where
line objects = Polyline { polylineId = "markerConnection" line objects = Polyline { polylineId = LeafletObjectID "markerConnection"
, style = [Style (LineStrokeColor "#f0f"), Style (LineStrokeWidth 4)] , style = [Style (LineStrokeColor "#f0f"), Style (LineStrokeWidth 4)]
, points = points objects , points = points objects
} }
...@@ -62,7 +62,7 @@ where ...@@ -62,7 +62,7 @@ where
addMarkerConnectingPolygon m addMarkerConnectingPolygon m
= upd (\l=:{LeafletMap|objects} -> {LeafletMap|l & objects = objects ++ [polygon objects]}) m = upd (\l=:{LeafletMap|objects} -> {LeafletMap|l & objects = objects ++ [polygon objects]}) m
where where
polygon objects = Polygon { polygonId = "markerConnection" polygon objects = Polygon { polygonId = LeafletObjectID "markerConnection"
, style = [ Style (PolygonLineStrokeColor "#000") , style = [ Style (PolygonLineStrokeColor "#000")
, Style (PolygonLineStrokeWidth 2) , Style (PolygonLineStrokeWidth 2)
, Style (PolygonFillColor "#0f0") , Style (PolygonFillColor "#0f0")
...@@ -75,6 +75,6 @@ where ...@@ -75,6 +75,6 @@ where
= upd (\l=:{LeafletMap|perspective={LeafletPerspective|cursor},objects} -> {LeafletMap|l & objects = withMarkerFromCursor cursor objects}) m = upd (\l=:{LeafletMap|perspective={LeafletPerspective|cursor},objects} -> {LeafletMap|l & objects = withMarkerFromCursor cursor objects}) m
where where
withMarkerFromCursor Nothing objects = objects withMarkerFromCursor Nothing objects = objects
withMarkerFromCursor (Just position) objects = objects ++ [Marker {markerId = "CURSOR", position= position, title = Nothing, icon = Nothing, selected = False, popup = Nothing}] withMarkerFromCursor (Just position) objects = objects ++ [Marker {markerId = LeafletObjectID "CURSOR", position= position, title = Nothing, icon = Nothing, selected = False, popup = Nothing}]
Start world = doTasks playWithMaps world Start world = doTasks playWithMaps world
...@@ -5,24 +5,24 @@ import iTasks ...@@ -5,24 +5,24 @@ import iTasks
leafletEditor :: Editor LeafletMap leafletEditor :: Editor LeafletMap
:: LeafletMap = :: LeafletMap =
{ perspective :: LeafletPerspective { perspective :: !LeafletPerspective
, tilesUrls :: [String] , tilesUrls :: ![String]
, objects :: [LeafletObject] //Markers, lines and polygon , objects :: ![LeafletObject] //Markers, lines and polygon
, icons :: [LeafletIcon] //Custom icons used by markers. They are indexed by 'iconId' string and cannot be changed once the map is loaded , icons :: ![LeafletIcon] //Custom icons used by markers. They are indexed by 'iconId' string and cannot be changed once the map is loaded
} }
:: LeafletPerspective = :: LeafletPerspective =
{ center :: LeafletLatLng { center :: !LeafletLatLng
, zoom :: Int , zoom :: !Int
, cursor :: Maybe LeafletLatLng , cursor :: !Maybe LeafletLatLng
, bounds :: Maybe LeafletBounds , bounds :: !Maybe LeafletBounds
} }
:: LeafletIconID :== String :: LeafletIconID =: LeafletIconID String
:: LeafletIcon = :: LeafletIcon =
{ iconId :: LeafletIconID { iconId :: !LeafletIconID
, iconUrl :: String , iconUrl :: !String
, iconSize :: (!Int,!Int) , iconSize :: !(!Int,!Int)
} }
:: LeafletLatLng = :: LeafletLatLng =
...@@ -41,7 +41,7 @@ leafletEditor :: Editor LeafletMap ...@@ -41,7 +41,7 @@ leafletEditor :: Editor LeafletMap
| Polygon !LeafletPolygon | Polygon !LeafletPolygon
| Window !LeafletWindow | Window !LeafletWindow
:: LeafletObjectID :== String :: LeafletObjectID =: LeafletObjectID String
:: LeafletMarker = :: LeafletMarker =
{ markerId :: !LeafletObjectID { markerId :: !LeafletObjectID
, position :: !LeafletLatLng , position :: !LeafletLatLng
...@@ -68,7 +68,7 @@ leafletEditor :: Editor LeafletMap ...@@ -68,7 +68,7 @@ leafletEditor :: Editor LeafletMap
, initPosition :: !LeafletWindowPos , initPosition :: !LeafletWindowPos
, title :: !String , title :: !String
, content :: !HtmlTag , content :: !HtmlTag
, relatedMarkers :: ![(LeafletObjectID, [LeafletStyleDef LeafletLineStyle])] // connecting lines are drawn between the window and the markers , relatedMarkers :: ![(!LeafletObjectID, ![LeafletStyleDef LeafletLineStyle])] // connecting lines are drawn between the window and the markers
// to visualise the relation // to visualise the relation
} }
...@@ -85,7 +85,7 @@ leafletEditor :: Editor LeafletMap ...@@ -85,7 +85,7 @@ leafletEditor :: Editor LeafletMap
| PolygonFillColor !String // html/css color definition | PolygonFillColor !String // html/css color definition
| PolygonFillOpacity !Real | PolygonFillOpacity !Real
:: CSSClass :== String :: CSSClass =: CSSClass String
:: LeafletStyleDef style = Style style :: LeafletStyleDef style = Style style
| Class CSSClass | Class CSSClass
...@@ -102,4 +102,3 @@ derive gEq LeafletMap, LeafletPerspective ...@@ -102,4 +102,3 @@ derive gEq LeafletMap, LeafletPerspective
derive gText LeafletMap, LeafletPerspective, LeafletLatLng derive gText LeafletMap, LeafletPerspective, LeafletLatLng
derive gEditor LeafletMap, LeafletPerspective, LeafletLatLng derive gEditor LeafletMap, LeafletPerspective, LeafletLatLng
derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletPolygonStyle derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletPolygonStyle
...@@ -2,15 +2,15 @@ implementation module iTasks.Extensions.GIS.Leaflet ...@@ -2,15 +2,15 @@ implementation module iTasks.Extensions.GIS.Leaflet
import iTasks import iTasks
import iTasks.UI.Definition, iTasks.UI.JS.Map, iTasks.UI.Editor, iTasks.UI.JS.Encoding import iTasks.UI.Definition, iTasks.UI.JS.Map, iTasks.UI.Editor, iTasks.UI.JS.Encoding
import StdMisc, Data.Tuple, Data.Error, Data.Func import StdMisc, Data.Tuple, Data.Error, Data.Func, Text
import qualified Data.Map as DM import qualified Data.Map as DM
from Text.HTML import instance toString HtmlTag from Text.HTML import instance toString HtmlTag
from iTasks.UI.Editor.Common import diffChildren from iTasks.UI.Editor.Common import diffChildren, :: ChildUpdate (..)
from StdArray import class Array(uselect), instance Array {} a from StdArray import class Array(uselect), instance Array {} a
LEAFLET_JS :== "/leaflet-1.1.0/leaflet.js" LEAFLET_JS :== "/leaflet-1.3.4/leaflet.js"
LEAFLET_JS_WINDOW :== "leaflet-window.js" LEAFLET_JS_WINDOW :== "leaflet-window.js"
LEAFLET_CSS :== "/leaflet-1.1.0/leaflet.css" LEAFLET_CSS :== "/leaflet-1.3.4/leaflet.css"
LEAFLET_CSS_WINDOW :== "leaflet-window.css" LEAFLET_CSS_WINDOW :== "leaflet-window.css"
:: IconOptions = :: IconOptions =
...@@ -29,8 +29,8 @@ LEAFLET_CSS_WINDOW :== "leaflet-window.css" ...@@ -29,8 +29,8 @@ LEAFLET_CSS_WINDOW :== "leaflet-window.css"
derive JSONEncode IconOptions derive JSONEncode IconOptions
derive JSEncode LeafletEdit, LeafletBounds, LeafletLatLng derive JSEncode LeafletEdit, LeafletBounds, LeafletLatLng, LeafletObjectID
derive JSDecode LeafletEdit, LeafletBounds, LeafletLatLng derive JSDecode LeafletEdit, LeafletBounds, LeafletLatLng, LeafletObjectID
CURSOR_OPTIONS :== {color = "#00f", opacity = 1.0, radius = 3} CURSOR_OPTIONS :== {color = "#00f", opacity = 1.0, radius = 3}
MAP_OPTIONS :== {attributionControl = False, zoomControl = True} MAP_OPTIONS :== {attributionControl = False, zoomControl = True}
...@@ -41,8 +41,9 @@ MAP_OPTIONS :== {attributionControl = False, zoomControl = True} ...@@ -41,8 +41,9 @@ MAP_OPTIONS :== {attributionControl = False, zoomControl = True}
| LDSetCenter !LeafletLatLng | LDSetCenter !LeafletLatLng
| LDSetCursor !LeafletLatLng | LDSetCursor !LeafletLatLng
| LDSetBounds !LeafletBounds | LDSetBounds !LeafletBounds
//Updating markers //Updating markers
| LDSelectMarker !LeafletObjectID | LDSelectMarker !LeafletObjectID
//Updating windows
| LDRemoveWindow !LeafletObjectID | LDRemoveWindow !LeafletObjectID
openStreetMapTiles :: String openStreetMapTiles :: String
...@@ -67,7 +68,10 @@ where ...@@ -67,7 +68,10 @@ where
,("tilesUrls", toJSON tilesUrls) ,("tilesUrls", toJSON tilesUrls)
,("icons", JSONArray [toJSON (iconId,{IconOptions|iconUrl=iconUrl,iconSize=[w,h]}) \\ {iconId,iconUrl,iconSize=(w,h)} <- icons]) ,("icons", JSONArray [toJSON (iconId,{IconOptions|iconUrl=iconUrl,iconSize=[w,h]}) \\ {iconId,iconUrl,iconSize=(w,h)} <- icons])
] ]
# attr = 'DM'.unions [mapAttr, sizeAttr (ExactSize 500) (ExactSize 150)] # attr = 'DM'.unions [ mapAttr
, sizeAttr (ExactSize 500) (ExactSize 150)
, 'DM'.singleton "viewMode" $ JSONBool $ mode =: View _
]
# children = map encodeUI objects # children = map encodeUI objects
= (Ok (uiac UIHtmlView attr children, val), world) = (Ok (uiac UIHtmlView attr children, val), world)
...@@ -81,7 +85,7 @@ where ...@@ -81,7 +85,7 @@ where
encodeUI (Polyline o) = let (JSONObject attr) = toJSON o in uia UIData ('DM'.fromList [("type",JSONString "polyline"):attr]) encodeUI (Polyline o) = let (JSONObject attr) = toJSON o in uia UIData ('DM'.fromList [("type",JSONString "polyline"):attr])
encodeUI (Polygon o) = let (JSONObject attr) = toJSON o in uia UIData ('DM'.fromList [("type",JSONString "polygon") : attr]) encodeUI (Polygon o) = let (JSONObject attr) = toJSON o in uia UIData ('DM'.fromList [("type",JSONString "polygon") : attr])
encodeUI (Window o) = let (JSONObject attr) = toJSON o encodeUI (Window o) = let (JSONObject attr) = toJSON o
dataMap = 'DM'.fromList [("type",JSONString "window"):attr] dataMap = 'DM'.fromList [("type",JSONString "window"): attr]
// translate HtmlTag to HTML code // translate HtmlTag to HTML code
dataMap` = 'DM'.put "content" (JSONString (toString o.content)) dataMap dataMap` = 'DM'.put "content" (JSONString (toString o.content)) dataMap
in uia UIData dataMap` in uia UIData dataMap`
...@@ -105,6 +109,8 @@ where ...@@ -105,6 +109,8 @@ where
initDOM me args world initDOM me args world
# (l,world) = findObject "L" world # (l,world) = findObject "L" world
# (domEl,world) = .? (me .# "domEl") world # (domEl,world) = .? (me .# "domEl") world
# (viewMode, world) = .? (me .# "attributes.viewMode") world
# viewMode = jsValToBool viewMode
//Create the map //Create the map
# (mapObj,world) = (l .# "map" .$ (domEl,MAP_OPTIONS)) world # (mapObj,world) = (l .# "map" .$ (domEl,MAP_OPTIONS)) world
# world = (me .# "map" .= mapObj) world # world = (me .# "map" .= mapObj) world
...@@ -122,31 +128,41 @@ where ...@@ -122,31 +128,41 @@ where
# (tilesUrls,world) = .? (me .# "attributes.tilesUrls") world # (tilesUrls,world) = .? (me .# "attributes.tilesUrls") world
# world = forall (addMapTilesLayer me mapObj) tilesUrls world # world = forall (addMapTilesLayer me mapObj) tilesUrls world
//Synchronize lat/lng bounds to server (they depend on the size of the map in the browser) //Synchronize lat/lng bounds to server (they depend on the size of the map in the browser)
# (taskId,world) = .? (me .# "attributes.taskId") world # world = case viewMode of
# (editorId,world) = .? (me .# "attributes.editorId") world True
# (bounds,world) = getMapBounds mapObj world = world
# (edit,world) = encodeOnClient [LDSetBounds bounds] world False
# (_,world) = ((me .# "doEditEvent") .$ (taskId,editorId,edit)) world # (taskId,world) = .? (me .# "attributes.taskId") world
# (editorId,world) = .? (me .# "attributes.editorId") world
# (bounds,world) = getMapBounds mapObj world
# (edit,world) = encodeOnClient [LDSetBounds bounds] world
# (_,world) = ((me .# "doEditEvent") .$ (taskId,editorId,edit)) world
= world
//Add initial objects //Add initial objects
# (objects,world) = .? (me .# "children") world # (objects,world) = .? (me .# "children") world
# world = createMapObjects me mapObj objects world # world = createMapObjects viewMode me mapObj objects world
//Add event handlers //Add event handlers
# (cb,world) = jsWrapFun (\a w -> onResize me w) world # (cb,world) = jsWrapFun (\a w -> onResize me w) world
# world = ((me .# "onResize") .= cb) world # world = ((me .# "onResize") .= cb) world
# (cb,world) = jsWrapFun (\a w -> onShow me w) world # (cb,world) = jsWrapFun (\a w -> onShow me w) world
# world = ((me .# "onShow") .= cb) world # world = ((me .# "onShow") .= cb) world
# (cb,world) = jsWrapFun (\a w -> onAttributeChange me a w) world # (cb,world) = jsWrapFun (\a w -> onAttributeChange me a w) world
# world = ((me .# "onAttributeChange") .= cb) world # world = ((me .# "onAttributeChange") .= cb) world
# (cb,world) = jsWrapFun (\a w -> onAfterChildInsert me a w) world # (cb,world) = jsWrapFun (\a w -> onAfterChildInsert viewMode me a w) world
# world = ((me .# "afterChildInsert") .= cb) world # world = ((me .# "afterChildInsert") .= cb) world
# (cb,world) = jsWrapFun (\a w -> onBeforeChildRemove me a w) world # (cb,world) = jsWrapFun (\a w -> onBeforeChildRemove me a w) world
# world = ((me .# "beforeChildRemove") .= cb) world # world = ((me .# "beforeChildRemove") .= cb) world
# (cb,world) = jsWrapFun (\a w -> onMapDragEnd me a w) world # world = case viewMode of
# (_,world) = (mapObj .# "addEventListener" .$ ("dragend",cb)) world True
# (cb,world) = jsWrapFun (\a w -> onMapZoomEnd me a w) world = world
# (_,world) = (mapObj .# "addEventListener" .$ ("zoomend",cb)) world False
# (cb,world) = jsWrapFun (\a w -> onMapClick me a w) world # (cb,world) = jsWrapFun (\a w -> onMapDragEnd me a w) world
# (_,world) = (mapObj .# "addEventListener" .$ ("click",cb)) world # (_,world) = (mapObj .# "addEventListener" .$ ("dragend",cb)) world
# (cb,world) = jsWrapFun (\a w -> onMapZoomEnd me a w) world
# (_,world) = (mapObj .# "addEventListener" .$ ("zoomend",cb)) world
# (cb,world) = jsWrapFun (\a w -> onMapClick me a w) world
# (_,world) = (mapObj .# "addEventListener" .$ ("click",cb)) world
= world
= (jsNull,world) = (jsNull,world)
onResize me world onResize me world
...@@ -205,11 +221,11 @@ where ...@@ -205,11 +221,11 @@ where
"zoom" = (jsNull,setMapZoom mapObj (args !! 1) world) "zoom" = (jsNull,setMapZoom mapObj (args !! 1) world)
"cursor" = (jsNull,setMapCursor me mapObj (toJSVal (args !! 1)) world) "cursor" = (jsNull,setMapCursor me mapObj (toJSVal (args !! 1)) world)
_ = (jsNull,world) _ = (jsNull,world)
onAfterChildInsert me args world onAfterChildInsert viewMode me args world
# (l, world) = findObject "L" world # (l, world) = findObject "L" world
# (mapObj,world) = .? (me .# "map") world # (mapObj,world) = .? (me .# "map") world
= (jsNull,createMapObject me mapObj l (toJSVal (args !! 1)) world) = (jsNull,createMapObject viewMode me mapObj l (toJSVal (args !! 1)) world)
onBeforeChildRemove me args world onBeforeChildRemove me args world
# (layer,world) = .? (toJSVal (args !! 1) .# "layer") world # (layer,world) = .? (toJSVal (args !! 1) .# "layer") world
...@@ -237,7 +253,7 @@ where ...@@ -237,7 +253,7 @@ where
where where
removeWindow idx layer world removeWindow idx layer world
# (layerWindowId, world) = .? (layer .# "attributes.windowId") world # (layerWindowId, world) = .? (layer .# "attributes.windowId") world
| not (jsIsUndefined layerWindowId) && jsValToString layerWindowId == windowId = | not (jsIsUndefined layerWindowId) && LeafletObjectID (jsValToString layerWindowId) === windowId =
snd (((me .# "removeChild") .$ idx) world) snd (((me .# "removeChild") .$ idx) world)
= world = world
...@@ -313,20 +329,20 @@ where ...@@ -313,20 +329,20 @@ where
# world = ((index .# jsValToString iconId) .= icon) world # world = ((index .# jsValToString iconId) .= icon) world
= world = world
createMapObjects me mapObj objects world createMapObjects viewMode me mapObj objects world
# (l, world) = findObject "L" world # (l, world) = findObject "L" world
= forall (\_ obj -> createMapObject me mapObj l obj) objects world = forall (\_ obj -> createMapObject viewMode me mapObj l obj) objects world
createMapObject me mapObj l object world createMapObject viewMode me mapObj l object world
# (type,world) = .? (object .# "attributes.type") world # (type,world) = .? (object .# "attributes.type") world
= case jsValToString type of = case jsValToString type of
"marker" = createMarker me mapObj l object world "marker" = createMarker me mapObj l object world
"polyline" = createPolyline me mapObj l object world "polyline" = createPolyline me mapObj l object world
"polygon" = createPolygon me mapObj l object world "polygon" = createPolygon me mapObj l object world
"window" = createWindow me mapObj l object world "window" = createWindow viewMode me mapObj l object world
_ = world _ = world
createMarker me mapObj l object world createMarker me mapObj l object world
# (markerId,world) = .? (object .# "attributes.markerId") world # (markerId,world) = .? (object .# "attributes.markerId") world
# (options,world) = jsEmptyObject world # (options,world) = jsEmptyObject world
//Set title //Set title
...@@ -347,7 +363,7 @@ where ...@@ -347,7 +363,7 @@ where
//Store marker ID, needed for related markers of windows //Store marker ID, needed for related markers of windows
# world = (layer .# "markerId" .= markerId) world # world = (layer .# "markerId" .= markerId) world
//Set click handler //Set click handler
# (cb,world) = jsWrapFun (\a w -> onMarkerClick me (jsValToString markerId) a w) world # (cb,world) = jsWrapFun (\a w -> onMarkerClick me (LeafletObjectID (jsValToString markerId)) a w) world
# (_,world) = (layer .# "addEventListener" .$ ("click",cb)) world # (_,world) = (layer .# "addEventListener" .$ ("click",cb)) world
//Add to map //Add to map
# (_,world) = (layer .# "addTo" .$ (toJSArg mapObj)) world # (_,world) = (layer .# "addTo" .$ (toJSArg mapObj)) world
...@@ -416,8 +432,8 @@ where ...@@ -416,8 +432,8 @@ where
= (options .# "className" .= cls) world = (options .# "className" .= cls) world
= abort "unknown style" = abort "unknown style"
createWindow me mapObj l object world createWindow viewMode me mapObj l object world
# (layer,world) = (l .# "window" .$ () ) world # (layer,world) = l .# "window" .$ () $ world
# world = (object .# "layer" .= layer) world # world = (object .# "layer" .= layer) world
# (position,world) = .? (object .# "attributes.initPosition") world # (position,world) = .? (object .# "attributes.initPosition") world
# (_, world) = (layer .# "setInitPos" .$ position) world # (_, world) = (layer .# "setInitPos" .$ position) world
...@@ -426,22 +442,42 @@ where ...@@ -426,22 +442,42 @@ where
# (content,world) = .? (object .# "attributes.content") world # (content,world) = .? (object .# "attributes.content") world
# (_, world) = (layer .# "setContent" .$ content) world # (_, world) = (layer .# "setContent" .$ content) world
# (relMarkers,world) = .? (object .# "attributes.relatedMarkers") world # (relMarkers,world) = .? (object .# "attributes.relatedMarkers") world
# world = forall (addRelatedMarker layer) relMarkers world # world = forall (\_ relMarker world -> snd $ (layer .# "addRelatedMarker" .$ relMarker $ world))
relMarkers
world
// inject function to send event on window remove // inject function to send event on window remove
# (windowId,world) = .? (object .# "attributes.windowId") world # world = case viewMode of
# (onWRemove, world) = jsWrapFun (onWindowRemove me (jsValToString windowId)) world True
# world = (layer .# "_onWindowClose" .= onWRemove) world = world
False
# (windowId,world) = .? (object .# "attributes.windowId") world
# (onWRemove, world) = jsWrapFun (onWindowRemove me (LeafletObjectID (jsValToString windowId))) world
= (layer .# "_onWindowClose" .= onWRemove) world
// inject function to handle window update
# (cb,world) = jsWrapFun (onUIChange layer) world
# world = ((object .# "onUIChange") .= cb) world
// add to map // add to map
# (_,world) = (layer .# "addTo" .$ (toJSArg mapObj)) world # (_,world) = (layer .# "addTo" .$ (toJSArg mapObj)) world
= world = world
where where
addRelatedMarker layer _ relMarker world onUIChange layer changes world
# (markerId, world) = .? (relMarker .# 0) world # world = foldl doChange world changes
# (lineStyle, world) = .? (relMarker .# 1) world = (jsNull, world)
# (lineOptions,world) = jsEmptyObject world where
# world = forall (applyLineStyle lineOptions) lineStyle world doChange world change
# (_, world) = (layer .# "addRelatedMarker" .$ (markerId, lineOptions