Merge branch 'master' into modernize-html-and-css

Examples/Applications/Incidone/Incidone/Util/TaskPatterns.icl

@@ -212,7 +212,7 @@ where
 
 syncNetworkChannel      :: String Int String (String -> m) (m -> String) (Shared sds ([m],Bool,[m],Bool)) -> Task () | iTask m & RWShared sds
 syncNetworkChannel server port msgSeparator decodeFun encodeFun channel
-    = tcpconnect server port channel {ConnectionHandlers|onConnect=onConnect,onData=onData,onShareChange=onShareChange,onDisconnect=onDisconnect} @! ()
+    = tcpconnect server port channel {ConnectionHandlers|onConnect=onConnect,onData=onData,onShareChange=onShareChange,onDisconnect=onDisconnect,onDestroy= \s->(Ok s, [])} @! ()
 where
     onConnect _ _ (received,receiveStopped,send,sendStopped)
         = (Ok "",if (not (isEmpty send)) (Just (received,False,[],sendStopped)) Nothing, map encodeFun send,False)

Examples/GIS/LeafletMapExample.icl

@@ -19,13 +19,13 @@ manipulateMap m = updateSharedInformation () [] m
 managePerspective :: (Shared sds LeafletMap) -> Task () | RWShared sds
 managePerspective m = updateSharedInformation (Title "Perspective") [] (mapReadWrite (\x -> x.LeafletMap.perspective,\p x -> Just {x & perspective = p}) Nothing m)  @! ()
 
+// objects can currently only be viewed, as the editor for `HtmlTag` only works in view mode
 manageMapObjects :: (Shared sds LeafletMap) -> Task () | RWShared sds
-manageMapObjects m = updateSharedInformation (Title "Manage objects") [UpdateAs toPrj fromPrj] m
+manageMapObjects m = viewSharedInformation (Title "View objects") [ViewAs toPrj] m
 				   -|| addDemoObjects m
 				   @! ()
 where
 	toPrj m = m.LeafletMap.objects
-	fromPrj m objects = {m & objects = objects}
 
 	addDemoObjects m
 		= enterChoiceAs "Add objects:" [ChooseFromCheckGroup fst] options snd
@@ -36,6 +36,8 @@ where
 			,("Marker at cursor position",addMarkerAtCursor m)
 			,("Line connecting current markers",addMarkerConnectingLine m)
 			,("Polygon from current markers",addMarkerConnectingPolygon m)
+			,("Circle at cursor position",addCircleAtCursor m)
+			,("Rectangle around current perspective",addRectangleAroundCurrentPerspective m)
 			]
 
 	addRandomMarker m
@@ -56,6 +58,7 @@ where
 		line objects = Polyline { polylineId = LeafletObjectID "markerConnection"
                                 , style      = [Style (LineStrokeColor "#f0f"), Style (LineStrokeWidth 4)]
                                 , points     = points objects
+                                , editable   = True
                                 }
 		points objects = [position \\ Marker {LeafletMarker|position} <- objects]
 
@@ -63,11 +66,12 @@ where
 		= upd (\l=:{LeafletMap|objects} -> {LeafletMap|l & objects = objects ++ [polygon objects]}) m
 	where
 		polygon objects = Polygon { polygonId = LeafletObjectID "markerConnection"
-                                  , style     = [ Style (PolygonLineStrokeColor "#000")
-                                                , Style (PolygonLineStrokeWidth 2)
-                                                , Style (PolygonFillColor "#0f0")
+                                  , style     = [ Style (AreaLineStrokeColor "#000")
+                                                , Style (AreaLineStrokeWidth 2)
+                                                , Style (AreaFillColor "#0f0")
                                                 ]
                                   , points    = points objects
+                                  , editable  = True
                                   }
 		points objects = [position \\ Marker {LeafletMarker|position} <- objects]
 
@@ -77,4 +81,16 @@ where
 		withMarkerFromCursor Nothing objects = objects
 		withMarkerFromCursor (Just position) objects = objects ++ [Marker {markerId = LeafletObjectID "CURSOR", position= position, title = Nothing, icon = Nothing, selected = False, popup = Nothing}]
 
+	addCircleAtCursor m
+		= upd (\l=:{LeafletMap|perspective={LeafletPerspective|cursor},objects} -> {LeafletMap|l & objects = withCircleFromCursor cursor objects}) m
+	where
+		withCircleFromCursor Nothing objects = objects
+		withCircleFromCursor (Just position) objects = objects ++ [Circle {circleId = LeafletObjectID "CIRCLE_CURSOR", center = position, radius = 100000.0, editable = True, style = []}]
+
+	addRectangleAroundCurrentPerspective m
+		= upd (\l=:{LeafletMap|perspective={LeafletPerspective|bounds},objects} -> {LeafletMap|l & objects = withRectangleAroundCurrentPerspective bounds objects}) m
+	where
+		withRectangleAroundCurrentPerspective Nothing objects = objects
+		withRectangleAroundCurrentPerspective (Just bounds) objects = objects ++ [Rectangle {rectangleId = LeafletObjectID "RECT_PERSPECTIVE", bounds = bounds, editable = True, style = []}]
+
 Start world = doTasks playWithMaps world

Libraries/iTasks/Engine.dcl

@@ -58,21 +58,22 @@ instance Startable (a,b) | Startable a & Startable b
 
 
 :: EngineOptions =
-	{ appName 		:: String
-	, appPath		:: FilePath // Location of the application's executable
+	{ appName       :: String
+	, appPath       :: FilePath // Location of the application's executable
 	, appVersion    :: String
-	, serverPort	:: Int
-    , serverUrl     :: String
+	, serverPort    :: Int
+	, serverUrl     :: String
 	, keepaliveTime :: Timespec
-    , sessionTime   :: Timespec
-    , persistTasks  :: Bool
+	, sessionTime   :: Timespec
+	, persistTasks  :: Bool
 	, autoLayout    :: Bool
+	, maxEvents     :: Int
 	, timeout       :: Maybe Int // The timeout
 	, distributed   :: Bool
-	, sdsPort		:: Int
-	, webDirPath 	:: FilePath  // Location of public files that are served by the iTask webserver
-	, storeDirPath 	:: FilePath  // Location of the application's persistent data files 
-	, tempDirPath 	:: FilePath  // Location for temporary files used in tasks
+	, sdsPort       :: Int
+	, webDirPath    :: FilePath  // Location of public files that are served by the iTask webserver
+	, storeDirPath  :: FilePath  // Location of the application's persistent data files 
+	, tempDirPath   :: FilePath  // Location for temporary files used in tasks
 	, saplDirPath   :: FilePath  // Location of the application's sapl files (client-side code)
 	}
 

Libraries/iTasks/Engine.icl

 implementation module iTasks.Engine
 
-import StdMisc, StdArray, StdList, StdOrdList, StdTuple, StdChar, StdFile, StdBool, StdEnum
+import Data.Func
+import Data.Functor
+import Data.Queue
+import Internet.HTTP
+import StdEnv
+import System.CommandLine
+import System.Directory
+import System.File
+import System.FilePath
+import System.GetOpt
+import System.OS
+import Text
+import iTasks.Internal.Distributed.Symbols
+import iTasks.Internal.EngineTasks
+import iTasks.Internal.IWorld
+import iTasks.Internal.SDS
+import iTasks.Internal.SDSService
+import iTasks.Internal.TaskServer
+import iTasks.Internal.TaskStore
+import iTasks.Internal.Util
+import iTasks.SDS.Sources.System
 import iTasks.WF.Combinators.Common
+import iTasks.WF.Definition
+import iTasks.WF.Tasks.SDS
 import iTasks.WF.Tasks.System
 
-import StdInt, StdChar, StdString
-from StdFunc import o, seqList, ::St, const, id
-
-import tcp
-import Internet.HTTP, System.GetOpt, Data.Func, Data.Functor
-
-from Data.Map import :: Map
-from Data.Queue import :: Queue(..)
-from Data.Set import :: Set, newSet
-
 import qualified Data.Map as DM
-from System.OS import IF_POSIX_OR_WINDOWS, OS_NEWLINE, IF_WINDOWS
-
-import Data.List, Data.Error, Data.Func, Data.Tuple, Math.Random, Text
-import System.Time, System.CommandLine, System.Environment, System.OSError, System.File, System.FilePath, System.Directory
-
-import iTasks.Internal.Util, iTasks.Internal.HtmlUtil
-import iTasks.Internal.IWorld, iTasks.Internal.WebService, iTasks.Internal.SDSService
-import qualified iTasks.Internal.SDS as SDS
-import iTasks.UI.Layout, iTasks.UI.Layout.Default
 
-from iTasks.WF.Tasks.SDS import get
-from iTasks.WF.Combinators.Tune import class tune(..), instance tune ApplyLayout Task, :: ApplyLayout(..)
-from iTasks.SDS.Combinators.Common import sdsFocus
-from iTasks.SDS.Sources.System import applicationOptions
-
-import iTasks.Internal.IWorld, iTasks.Internal.TaskEval, iTasks.Internal.TaskStore
-import iTasks.Internal.Util
-import iTasks.Internal.TaskServer
-import iTasks.Internal.EngineTasks
-import iTasks.Internal.Distributed.Symbols
-
-from Sapl.Linker.LazyLinker import generateLoaderState, :: LoaderStateExt
-from Sapl.Linker.SaplLinkerShared import :: SkipSet
-from Sapl.Target.Flavour import :: Flavour, toFlavour
+from TCPIP import :: Timeout
+from StdFunc import :: St, seqList
 
 MAX_EVENTS 		        :== 5
 
@@ -49,23 +40,30 @@ doTasks startable world = doTasksWithOptions defaultEngineCLIOptions startable w
 
 doTasksWithOptions :: ([String] EngineOptions -> MaybeError [String] EngineOptions) a !*World -> *World | Startable a
 doTasksWithOptions initFun startable world
-	# (cli,world)			= getCommandLine world
-	# (options,world)       = defaultEngineOptions world
-	# mbOptions             = initFun cli options
-	| mbOptions =:(Error _) = show (fromError mbOptions) world
-	# options               = fromOk mbOptions
-	# iworld				= createIWorld options world
-	# (res,iworld) 			= initJSCompilerState iworld
-	| res =:(Error _) 		= show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
-	# (symbolsResult, iworld) = initSymbolsShare options.distributed options.appName iworld
+	# (cli,world)                = getCommandLine world
+	# (options,world)            = defaultEngineOptions world
+	# mbOptions                  = initFun cli options
+	| mbOptions =:(Error _)      = show (fromError mbOptions) world
+	# options                    = fromOk mbOptions
+	# iworld                     = createIWorld options world
+	# (res,iworld)               = initJSCompilerState iworld
+	| res =:(Error _)            = show ["Fatal error: " +++ fromError res] (destroyIWorld iworld)
+	# (symbolsResult, iworld)    = initSymbolsShare options.distributed options.appName iworld
 	| symbolsResult =: (Error _) = show ["Error reading symbols while required: " +++ fromError symbolsResult] (destroyIWorld iworld)
-	# iworld				= serve (startupTasks options) (tcpTasks options.serverPort options.keepaliveTime)
-	                                engineTasks (timeout options.timeout) iworld
+	# iworld                     = serve (startupTasks options) (tcpTasks options.serverPort options.keepaliveTime) (timeout options.timeout) iworld
 	= destroyIWorld iworld
 where
     webTasks = [t \\ WebTask t <- toStartable startable]
-	startupTasks {distributed, sdsPort} = (if distributed [case onStartup (sdsServiceTask sdsPort) of StartupTask t = t;] []) ++ [t \\ StartupTask t <- toStartable startable]
-	hasWebTasks = not (webTasks =: [])
+	startupTasks {distributed, sdsPort}
+		//If distributed, start sds service task
+		=  (if distributed [startTask (sdsServiceTask sdsPort)] [])
+		++ [startTask flushWritesWhenIdle
+		//If there no webtasks, stop when stable, otherwise cleanup old sessions
+		   ,startTask if (webTasks =: []) stopOnStable removeOutdatedSessions
+		//Start all startup tasks
+		   :[t \\ StartupTask t <- toStartable startable]]
+
+	startTask t = {StartupTask|attributes=defaultValue,task=TaskWrapper t}
 
 	initSymbolsShare False _ iworld = (Ok (), iworld)
 	initSymbolsShare True appName iworld = case storeSymbols (IF_WINDOWS (appName +++ ".exe") appName) iworld of
@@ -78,16 +76,6 @@ where
 		| otherwise
 			= [(serverPort,httpServer serverPort keepaliveTime (engineWebService webTasks) taskOutput)]
 
-	engineTasks =
- 		[BackgroundTask updateClock,
- 		 BackgroundTask (processEvents MAX_EVENTS)
-		:if (webTasks =: [])
-			[BackgroundTask stopOnStable]
-			[BackgroundTask removeOutdatedSessions
-		 	,BackgroundTask flushWritesWhenIdle
-			]
-		]
-
 	// The iTasks engine consist of a set of HTTP Web services
 	engineWebService :: [WebTask] -> [WebService (Map InstanceNo TaskOutput) (Map InstanceNo TaskOutput)]
 	engineWebService webtasks =
@@ -114,7 +102,7 @@ defaultEngineCLIOptions [argv0:argv] defaults
 where
 	opts :: [OptDescr ((Maybe EngineOptions) -> Maybe EngineOptions)]
 	opts =
-		[ Option ['?'] ["help"] (NoArg $ const Nothing)
+		[ Option ['?'] ["help"] (NoArg (\_->Nothing))
 			"Display this message"
 		, Option ['p'] ["port"] (ReqArg (\p->fmap \o->{o & serverPort=toInt p}) "PORT")
 			("Specify the HTTP port (default: " +++ toString defaults.serverPort +++ ")")
@@ -122,6 +110,8 @@ where
 			"Specify the timeout in ms (default: 500)\nIf not given, use an indefinite timeout."
 		, Option [] ["keepalive"] (ReqArg (\p->fmap \o->{o & keepaliveTime={tv_sec=toInt p,tv_nsec=0}}) "SECONDS")
 			"Specify the keepalive time in seconds (default: 300)"
+		, Option [] ["maxevents"] (ReqArg (\p->fmap \o->{o & maxEvents=toInt p}) "NUM")
+			"Specify the maximum number of events to process per loop (default: 5)"
 		, Option [] ["sessiontime"] (ReqArg (\p->fmap \o->{o & sessionTime={tv_sec=toInt p,tv_nsec=0}}) "SECONDS")
 			"Specify the expiry time for a session in seconds (default: 60)"
 		, Option [] ["autolayout"] (NoArg (fmap \o->{o & autoLayout=True}))
@@ -208,22 +198,23 @@ defaultEngineOptions world
 	# appDir             = takeDirectory appPath
 	# appName            = (dropExtension o dropDirectory) appPath
 	# options =
-		{ appName			= appName
-		, appPath			= appPath
-		, appVersion        = appVersion
-		, serverPort		= IF_POSIX_OR_WINDOWS 8080 80
-        , serverUrl         = "http://localhost/"
-		, keepaliveTime     = {tv_sec=300,tv_nsec=0} // 5 minutes
-		, sessionTime       = {tv_sec=60,tv_nsec=0}  // 1 minute, (the client pings every 10 seconds by default)
-        , persistTasks      = False
-		, autoLayout        = True
-		, distributed       = False
-		, sdsPort			= 9090
-		, timeout			= Just 500
-		, webDirPath 		= appDir </> appName +++ "-www"
-		, storeDirPath      = appDir </> appName +++ "-data" </> "stores"
-		, tempDirPath       = appDir </> appName +++ "-data" </> "tmp"
-		, saplDirPath 	    = appDir </> appName +++ "-sapl"
+		{ appName        = appName
+		, appPath        = appPath
+		, appVersion     = appVersion
+		, serverPort     = IF_POSIX_OR_WINDOWS 8080 80
+		, serverUrl      = "http://localhost/"
+		, keepaliveTime  = {tv_sec=300,tv_nsec=0} // 5 minutes
+		, sessionTime    = {tv_sec=60,tv_nsec=0}  // 1 minute, (the client pings every 10 seconds by default)
+		, persistTasks   = False
+		, autoLayout     = True
+		, distributed    = False
+		, maxEvents      = 5
+		, sdsPort        = 9090
+		, timeout        = Nothing//Just 500
+		, webDirPath     = appDir </> appName +++ "-www"
+		, storeDirPath   = appDir </> appName +++ "-data" </> "stores"
+		, tempDirPath    = appDir </> appName +++ "-data" </> "tmp"
+		, saplDirPath    = appDir </> appName +++ "-sapl"
 		}
 	= (options,world)
 
@@ -256,3 +247,29 @@ determineAppVersion appPath world
 	# version           = strfTime "%Y%m%d-%H%M%S" tm
 	= (version,world)
 
+timeout :: !(Maybe Timeout) !*IWorld -> (!Maybe Timeout,!*IWorld)
+timeout mt iworld = case read taskEvents EmptyContext iworld of
+	//No events
+	(Ok (ReadingDone (Queue [] [])),iworld=:{sdsNotifyRequests,world})
+		# (ts, world) = nsTime world
+		= ( minListBy lesser [mt:flatten (map (getTimeoutFromClock ts) ('DM'.elems sdsNotifyRequests))]
+		  , {iworld & world = world})
+	(Ok (ReadingDone (Queue _ _)), iworld)               = (Just 0,iworld)   //There are still events, don't wait
+	(Error _,iworld)            = (Just 500,iworld) //Keep retrying, but not too fast
+where
+	lesser (Just x) (Just y) = x < y
+	lesser (Just _) Nothing  = True
+	lesser _        _        = False
+
+	getTimeoutFromClock :: Timespec (Map SDSNotifyRequest Timespec) -> [Maybe Timeout]
+	getTimeoutFromClock now requests = map getTimeoutFromClock` ('DM'.toList requests)
+	where
+		getTimeoutFromClock` :: (!SDSNotifyRequest, !Timespec) -> Maybe Timeout
+		getTimeoutFromClock` (snr=:{cmpParam=(ts :: ClockParameter Timespec)}, reqTimespec)
+			| startsWith "$IWorld:timespec$" snr.reqSDSId && ts.interval <> zero
+				# fire = iworldTimespecNextFire now reqTimespec ts
+				= Just (max 0 (toMs fire - toMs now))
+			= mt
+		getTimeoutFromClock` _ = mt
+
+	toMs x = x.tv_sec * 1000 + x.tv_nsec / 1000000

Libraries/iTasks/Extensions/Device/_Common.icl

@@ -15,6 +15,7 @@ deviceRequest request close
 		, onData	 = onData
 		, onShareChange  = onShareChange
 		, onDisconnect   = onDisconnect
+		, onDestroy= \s->(Ok s, [])
 		} 
 	>>= \{DeviceRequestState|result} -> return result            
 where

Libraries/iTasks/Extensions/Distributed/Authentication.icl

@@ -38,6 +38,7 @@ authServer port = tcplisten port True authServerShare {ConnectionHandlers
 	, onData		= onData
 	, onShareChange		= onShareChange
 	, onDisconnect 		= onDisconnect
+	, onDestroy         = \s->(Ok s, [])
 	} -|| (process authServerShare) @! ()
 where
 	onConnect :: ConnectionId String AuthShare -> (MaybeErrorString AuthServerState, Maybe AuthShare, [String], Bool)
@@ -134,6 +135,7 @@ where
                         , onData	 = onData
 			, onShareChange  = onShareChange
                         , onDisconnect   = onDisconnect
+                        , onDestroy      = \s->(Ok s, [])
                         }) @? taskResult)
 		>>- \(resps,_) -> case resps of
 					[resp:_]  -> return (fromJSON (fromString (base64Decode resp)))

Libraries/iTasks/Extensions/Editors/DynamicEditor.dcl

+definition module iTasks.Extensions.Editors.DynamicEditor
+
+import iTasks
+
+:: DynamicEditor a =: DynamicEditor [DynamicEditorElement]
+// phantom type only needed for top level
+:: DynamicEditorValue a = DynamicEditorValue !DynamicConsId !DEVal | Undefined // TODO: Undefined can be removed once we have parametrised editors
+
+:: DEVal = DEApplication ![(!DynamicConsId, !DEVal)]
+         | DEJSONValue   !JSONNode
+
+derive class iTask DynamicEditorValue
+
+:: DynamicEditorElement = DynamicCons !DynamicCons | DynamicConsGroup !String ![DynamicCons]
+:: DynamicCons
+:: DynamicConsOption = HideIfOnlyChoice | UseAsDefault | LayoutVertical
+
+(<<@@@) infixl 2 :: !DynamicCons !DynamicConsOption -> DynamicCons
+(@@@>>) infixr 2 :: !DynamicConsOption !DynamicCons -> DynamicCons
+
+:: DynamicConsId :== String
+:: DynamicConsBuilder =     FunctionCons     !Dynamic
+                     | E.a: CustomEditorCons !(Editor a) & JSONEncode{|*|}, JSONDecode{|*|}, gText{|*|}, TC a
+                     |      ListCons         !Dynamic    //* must contain a value of type [a] -> b
+
+functionCons     :: !String !String !a          -> DynamicCons | TC a
+listCons         :: !String !String !([a] -> b) -> DynamicCons | TC a & TC b
+customEditorCons :: !String !String !(Editor a) -> DynamicCons | TC, JSONEncode{|*|}, JSONDecode{|*|}, gText{|*|} a
+// dynamic variants are required because this is the only way to use quantified type variables
+functionConsDyn :: !String !String !Dynamic -> DynamicCons
+listConsDyn     :: !String !String !Dynamic -> DynamicCons
+
+dynamicEditor :: !(DynamicEditor a) -> Editor (DynamicEditorValue a) | TC a
+parametrisedDynamicEditor
+	:: !(p -> DynamicEditor a) -> Editor (!p, !DynamicEditorValue a)
+	| TC a & gEq{|*|}, JSONEncode{|*|}, JSONDecode{|*|} p
+
+toValue              :: !(DynamicEditor a) !(DynamicEditorValue a) -> a | TC a
+dynEditorValToString :: !(DynamicEditor a) !(DynamicEditorValue a) -> String

Libraries/iTasks/Extensions/Email.icl

@@ -4,7 +4,7 @@ import Text
 
 sendEmail :: ![EmailOpt] !String !String !String !String -> Task ()
 sendEmail opts subject body sender recipient
-	= tcpconnect server port (constShare ()) {ConnectionHandlers|onConnect=onConnect,whileConnected=whileConnected,onDisconnect=onDisconnect}
+	= tcpconnect server port (constShare ()) {ConnectionHandlers|onConnect=onConnect,whileConnected=whileConnected,onDisconnect=onDisconnect,onDestroy= \s->(Ok s, [])}
 	@! ()
 where
 	server 	= getServerOpt opts

Libraries/iTasks/Extensions/GIS/Leaflet.dcl

@@ -36,10 +36,14 @@ leafletEditor :: Editor LeafletMap
     }
 
 :: LeafletObject
-    = Marker   !LeafletMarker
-    | Polyline !LeafletPolyline
-    | Polygon  !LeafletPolygon
-    | Window   !LeafletWindow
+    = Marker    !LeafletMarker
+    | Polyline  !LeafletPolyline
+    | Polygon   !LeafletPolygon
+    | Circle    !LeafletCircle
+    | Rectangle !LeafletRectangle
+    | Window    !LeafletWindow
+
+leafletObjectIdOf :: !LeafletObject -> LeafletObjectID
 
 :: LeafletObjectID =: LeafletObjectID String
 :: LeafletMarker =
@@ -55,12 +59,29 @@ leafletEditor :: Editor LeafletMap
     { polylineId    :: !LeafletObjectID
     , points        :: ![LeafletLatLng]
     , style         :: ![LeafletStyleDef LeafletLineStyle]
+    , editable      :: !Bool
     }
 
 :: LeafletPolygon =
     { polygonId     :: !LeafletObjectID
     , points        :: ![LeafletLatLng]
-    , style         :: ![LeafletStyleDef LeafletPolygonStyle]
+    , style         :: ![LeafletStyleDef LeafletAreaStyle]
+    , editable      :: !Bool
+    }
+
+:: LeafletCircle =
+    { circleId :: !LeafletObjectID
+    , center   :: !LeafletLatLng
+    , radius   :: !Real            //* the radius (in meters)
+    , style    :: ![LeafletStyleDef LeafletAreaStyle]
+    , editable :: !Bool
+    }
+
+:: LeafletRectangle =
+    { rectangleId   :: !LeafletObjectID
+    , bounds        :: !LeafletBounds
+    , style         :: ![LeafletStyleDef LeafletAreaStyle]
+    , editable      :: !Bool
     }
 
 :: LeafletWindow =
@@ -77,13 +98,13 @@ leafletEditor :: Editor LeafletMap
                        | LineOpacity     !Real   // between 0.0 and 1.0
                        | LineDashArray   !String // a list of comma separated lengths of alternating dashes and gaps (e.g. "1,5,2,5")
 
-:: LeafletPolygonStyle = PolygonLineStrokeColor !String // html/css color definition
-                       | PolygonLineStrokeWidth !Int
-                       | PolygonLineOpacity     !Real   // between 0.0 and 1.0
-                       | PolygonLineDashArray   !String // a list of comma separated lengths of alternating dashes and gaps (e.g. "1,5,2,5")
-                       | PolygonNoFill                  // inside of polygone is not filled, all other fill options are ignored
-                       | PolygonFillColor       !String // html/css color definition
-                       | PolygonFillOpacity     !Real
+:: LeafletAreaStyle = AreaLineStrokeColor !String // html/css color definition
+                    | AreaLineStrokeWidth !Int
+                    | AreaLineOpacity     !Real   // between 0.0 and 1.0
+                    | AreaLineDashArray   !String // a list of comma separated lengths of alternating dashes and gaps (e.g. "1,5,2,5")
+                    | AreaNoFill                  // inside of polygone is not filled, all other fill options are ignored
+                    | AreaFillColor       !String // html/css color definition
+                    | AreaFillOpacity     !Real
 
 :: CSSClass =: CSSClass String
 :: LeafletStyleDef style = Style style
@@ -101,4 +122,4 @@ derive gDefault   LeafletMap, LeafletPerspective, LeafletLatLng
 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
+derive class iTask LeafletIcon, LeafletBounds, LeafletObject, LeafletMarker, LeafletPolyline, LeafletPolygon, LeafletWindow, LeafletWindowPos, LeafletLineStyle, LeafletStyleDef, LeafletAreaStyle, LeafletObjectID

Libraries/iTasks/Extensions/GIS/Leaflet.icl

@@ -8,10 +8,12 @@ from Text.HTML import instance toString HtmlTag
 from iTasks.UI.Editor.Common import diffChildren, :: ChildUpdate (..)
 from StdArray import class Array(uselect), instance Array {} a
 
-LEAFLET_JS         :== "/leaflet-1.3.4/leaflet.js"
-LEAFLET_JS_WINDOW  :== "leaflet-window.js"
-LEAFLET_CSS        :== "/leaflet-1.3.4/leaflet.css"
-LEAFLET_CSS_WINDOW :== "leaflet-window.css"
+LEAFLET_JS           :== "/leaflet-1.3.4/leaflet.js"
+LEAFLET_JS_WINDOW    :== "leaflet-window.js"
+// https://github.com/Leaflet/Leaflet.Editable
+LEAFLET_JS_EDITABLE  :== "Leaflet.Editable.js"
+LEAFLET_CSS          :== "/leaflet-1.3.4/leaflet.css"
+LEAFLET_CSS_WINDOW   :== "leaflet-window.css"
 
 :: IconOptions =
     { iconUrl   :: !String
@@ -20,6 +22,7 @@ LEAFLET_CSS_WINDOW :== "leaflet-window.css"
 :: MapOptions =
     { attributionControl    :: !Bool
     , zoomControl           :: !Bool
+    , editable              :: !Bool
     }
 :: CursorOptions =
     { color     :: !String
@@ -29,11 +32,19 @@ LEAFLET_CSS_WINDOW :== "leaflet-window.css"
 
 derive JSONEncode IconOptions
 
-derive JSEncode LeafletEdit, LeafletBounds, LeafletLatLng, LeafletObjectID
-derive JSDecode LeafletEdit, LeafletBounds, LeafletLatLng, LeafletObjectID
+derive JSEncode LeafletEdit, LeafletBounds, LeafletLatLng, LeafletObjectID, LeafletObjectUpdate
+derive JSDecode LeafletEdit, LeafletBounds, LeafletLatLng, LeafletObjectID, LeafletObjectUpdate
 
 CURSOR_OPTIONS  :== {color = "#00f", opacity = 1.0, radius = 3}
-MAP_OPTIONS     :== {attributionControl = False, zoomControl = True}
+MAP_OPTIONS     :== {attributionControl = False, zoomControl = True, editable = True}
+
+leafletObjectIdOf :: !LeafletObject -> LeafletObjectID
+leafletObjectIdOf (Marker m)    = m.markerId
+leafletObjectIdOf (Polyline p)  = p.polylineId
+leafletObjectIdOf (Polygon p)   = p.polygonId
+leafletObjectIdOf (Circle c)    = c.circleId
+leafletObjectIdOf (Rectangle r) = r.rectangleId
+leafletObjectIdOf (Window w)    = w.windowId
 
 :: LeafletEdit
     //Perspective
@@ -45,6 +56,13 @@ MAP_OPTIONS     :== {attributionControl = False, zoomControl = True}
     | LDSelectMarker    !LeafletObjectID
     //Updating windows
     | LDRemoveWindow    !LeafletObjectID
+    | LDUpdateObject    !LeafletObjectID !LeafletObjectUpdate
+
+:: LeafletObjectUpdate
+	= UpdatePolyline  ![LeafletLatLng]
+	| UpdatePolygon   ![LeafletLatLng]
+	| UpdateCircle    !LeafletLatLng !Real
+	| UpdateRectangle !LeafletBounds
 
 openStreetMapTiles :: String
 openStreetMapTiles = "http://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png"
@@ -85,6 +103,8 @@ where
                           in uia UIData dataMap`
 	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 (Circle o) = let (JSONObject attr) = toJSON o in uia UIData ('DM'.fromList [("type",JSONString "circle"): attr])