Commit 7bc88da4 authored by Steffen Michels's avatar Steffen Michels

use newtypes instead of synonyms for leaflet ID types

parent ae9635ae
......@@ -43,7 +43,7 @@ where
>>- \marker -> upd (\l=:{LeafletMap|objects} -> {LeafletMap|l & objects = objects ++ [marker]}) m
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
lat = 52.0 + (toReal (500 + (rLat rem 1000)) / 1000.0)
lng = 6.0 + (toReal (500 + (rLng rem 1000)) / 1000.0)
......@@ -53,7 +53,7 @@ where
addMarkerConnectingLine m
= upd (\l=:{LeafletMap|objects} -> {LeafletMap|l & objects = objects ++ [line objects]}) m
where
line objects = Polyline { polylineId = "markerConnection"
line objects = Polyline { polylineId = LeafletObjectID "markerConnection"
, style = [Style (LineStrokeColor "#f0f"), Style (LineStrokeWidth 4)]
, points = points objects
}
......@@ -62,7 +62,7 @@ where
addMarkerConnectingPolygon m
= upd (\l=:{LeafletMap|objects} -> {LeafletMap|l & objects = objects ++ [polygon objects]}) m
where
polygon objects = Polygon { polygonId = "markerConnection"
polygon objects = Polygon { polygonId = LeafletObjectID "markerConnection"
, style = [ Style (PolygonLineStrokeColor "#000")
, Style (PolygonLineStrokeWidth 2)
, Style (PolygonFillColor "#0f0")
......@@ -75,6 +75,6 @@ where
= upd (\l=:{LeafletMap|perspective={LeafletPerspective|cursor},objects} -> {LeafletMap|l & objects = withMarkerFromCursor cursor objects}) m
where
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
......@@ -18,7 +18,7 @@ leafletEditor :: Editor LeafletMap
, bounds :: !Maybe LeafletBounds
}
:: LeafletIconID :== String
:: LeafletIconID =: LeafletIconID String
:: LeafletIcon =
{ iconId :: !LeafletIconID
, iconUrl :: !String
......@@ -41,7 +41,7 @@ leafletEditor :: Editor LeafletMap
| Polygon !LeafletPolygon
| Window !LeafletWindow
:: LeafletObjectID :== String
:: LeafletObjectID =: LeafletObjectID String
:: LeafletMarker =
{ markerId :: !LeafletObjectID
, position :: !LeafletLatLng
......@@ -85,7 +85,7 @@ leafletEditor :: Editor LeafletMap
| PolygonFillColor !String // html/css color definition
| PolygonFillOpacity !Real
:: CSSClass :== String
:: CSSClass =: CSSClass String
:: LeafletStyleDef style = Style style
| Class CSSClass
......@@ -102,4 +102,3 @@ derive gEq LeafletMap, LeafletPerspective
derive gText LeafletMap, LeafletPerspective, LeafletLatLng
derive gEditor LeafletMap, LeafletPerspective, LeafletLatLng
derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletPolygonStyle
......@@ -29,8 +29,8 @@ LEAFLET_CSS_WINDOW :== "leaflet-window.css"
derive JSONEncode IconOptions
derive JSEncode LeafletEdit, LeafletBounds, LeafletLatLng
derive JSDecode LeafletEdit, LeafletBounds, LeafletLatLng
derive JSEncode LeafletEdit, LeafletBounds, LeafletLatLng, LeafletObjectID
derive JSDecode LeafletEdit, LeafletBounds, LeafletLatLng, LeafletObjectID
CURSOR_OPTIONS :== {color = "#00f", opacity = 1.0, radius = 3}
MAP_OPTIONS :== {attributionControl = False, zoomControl = True}
......@@ -238,7 +238,7 @@ where
where
removeWindow idx layer 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)
= world
......@@ -327,7 +327,7 @@ where
"window" = createWindow me mapObj l object world
_ = world
createMarker me mapObj l object world
createMarker me mapObj l object world
# (markerId,world) = .? (object .# "attributes.markerId") world
# (options,world) = jsEmptyObject world
//Set title
......@@ -348,7 +348,7 @@ where
//Store marker ID, needed for related markers of windows
# world = (layer .# "markerId" .= markerId) world
//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
//Add to map
# (_,world) = (layer .# "addTo" .$ (toJSArg mapObj)) world
......@@ -432,7 +432,7 @@ where
world
// inject function to send event on window remove
# (windowId,world) = .? (object .# "attributes.windowId") world
# (onWRemove, world) = jsWrapFun (onWindowRemove me (jsValToString windowId)) world
# (onWRemove, world) = jsWrapFun (onWindowRemove me (LeafletObjectID (jsValToString windowId))) world
# world = (layer .# "_onWindowClose" .= onWRemove) world
// inject function to handle window update
# (cb,world) = jsWrapFun (onUIChange layer) world
......@@ -499,11 +499,11 @@ where
app m (LDSetBounds bounds) = {LeafletMap|m & perspective = {m.perspective & bounds = Just bounds}}
app m (LDSelectMarker markerId) = {LeafletMap|m & objects = map (sel markerId) m.LeafletMap.objects}
where
sel x (Marker m=:{LeafletMarker|markerId}) = Marker {LeafletMarker|m & selected = markerId == x}
sel x (Marker m=:{LeafletMarker|markerId}) = Marker {LeafletMarker|m & selected = markerId === x}
sel x o = o
app m (LDRemoveWindow idToRemove) = {LeafletMap|m & objects = filter notToRemove m.LeafletMap.objects}
where
notToRemove (Window {windowId}) = windowId <> idToRemove
notToRemove (Window {windowId}) = windowId =!= idToRemove
notToRemove _ = True
app m _ = m
onEdit _ _ msk ust = (Ok (NoChange,msk),ust)
......@@ -527,7 +527,7 @@ where
= center ++ zoom ++ cursor
updateFromOldToNew :: !LeafletObject !LeafletObject -> ChildUpdate
updateFromOldToNew (Window old) (Window new) | old.windowId == new.windowId && not (isEmpty changes) =
updateFromOldToNew (Window old) (Window new) | old.windowId === new.windowId && not (isEmpty changes) =
ChildUpdate $ ChangeUI changes []
where
changes = catMaybes
......@@ -551,7 +551,7 @@ gEditor{|LeafletMap|} = leafletEditor
gDefault{|LeafletMap|}
= {LeafletMap|perspective=defaultValue, tilesUrls = [openStreetMapTiles], objects = [Marker homeMarker], icons = []}
where
homeMarker = {markerId = "home", position= {LeafletLatLng|lat = 51.82, lng = 5.86}, title = Just "HOME", icon = Nothing, popup = Nothing, selected = False}
homeMarker = {markerId = LeafletObjectID "home", position= {LeafletLatLng|lat = 51.82, lng = 5.86}, title = Just "HOME", icon = Nothing, popup = Nothing, selected = False}
gDefault{|LeafletPerspective|}
= {LeafletPerspective|center = {LeafletLatLng|lat = 51.82, lng = 5.86}, zoom = 7, cursor = Nothing, bounds = Nothing}
......@@ -565,5 +565,4 @@ derive gDefault LeafletLatLng
derive gEq LeafletMap, LeafletPerspective
derive gText LeafletMap, LeafletPerspective, LeafletLatLng
derive gEditor LeafletPerspective, LeafletLatLng
derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletEdit, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletPolygonStyle
derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletEdit, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletPolygonStyle, LeafletObjectID, CSSClass, LeafletIconID
......@@ -4,9 +4,9 @@ implementation module iTasks.Extensions.GIS.LeafletNavalIcons
*/
from iTasks.Extensions.GIS.Leaflet import :: LeafletIcon(..), :: LeafletIconID(..)
from StdFunc import o
import StdString, StdInt, StdList, Data.Maybe
import StdString, StdInt, StdList, Data.Maybe, Text
URL iconId :== "/leaflet-naval-icons/" +++ iconId +++ ".png"
URL (LeafletIconID iconId) :== concat ["/leaflet-naval-icons/", iconId, ".png"]
SIZE :== (24,24)
instance toString ShipIconColor
......@@ -29,6 +29,7 @@ where
* Find the right icon based on a heading and color
*/
shipIconId :: (Maybe ShipIconHeading) ShipIconColor Bool -> LeafletIconID
shipIconId mbHeading color selected = toString color +++ if selected "-sel" "" +++ maybe "" toRoundedHeading mbHeading
shipIconId mbHeading color selected =
LeafletIconID (concat [toString color, if selected "-sel" "", maybe "" toRoundedHeading mbHeading])
where
toRoundedHeading h = "-" +++ toString (((h rem 360) / 15) * 15)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment