Commit 68b969d1 authored by Steffen Michels's avatar Steffen Michels

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

parents ffedc8de e68cf17f
Pipeline #20794 passed with stage
in 4 minutes and 44 seconds
......@@ -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)
......
......@@ -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
......@@ -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)
}
......
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
......@@ -15,6 +15,7 @@ deviceRequest request close
, onData = onData
, onShareChange = onShareChange
, onDisconnect = onDisconnect
, onDestroy= \s->(Ok s, [])
}
>>= \{DeviceRequestState|result} -> return result
where
......
......@@ -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)))
......
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
This diff is collapsed.
......@@ -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
......
......@@ -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
......@@ -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])