Skip to content
GitLab
Explore
Sign in
Primary navigation
Search or go to…
Project
W
walint
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package registry
Container registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
This is an archived project. Repository and other project resources are read-only.
Show more breadcrumbs
hub
walint
Commits
8082e9ef
Commit
8082e9ef
authored
3 years ago
by
stuebinm
Browse files
Options
Downloads
Patches
Plain Diff
badges are set on objects, not layers
(and `url` is, too)
parent
766f883e
Branches
Branches containing commit
No related tags found
No related merge requests found
Pipeline
#10017
passed
3 years ago
Stage: build
Changes
2
Pipelines
1
Show whitespace changes
Inline
Side-by-side
Showing
2 changed files
lib/Properties.hs
+44
-41
44 additions, 41 deletions
lib/Properties.hs
lib/TiledAbstract.hs
+5
-1
5 additions, 1 deletion
lib/TiledAbstract.hs
with
49 additions
and
42 deletions
lib/Properties.hs
+
44
−
41
View file @
8082e9ef
...
...
@@ -68,7 +68,7 @@ checkMap = do
$
complain
"The map must have one layer named
\"
start
\"
."
unlessLayer
(
\
l
->
getName
l
==
"floorLayer"
&&
layerType
l
==
"objectgroup"
)
$
complain
"The map must have one layer named
\"
floorLayer
\"
of type
\"
objectgroup
\"
."
unlessLayer
(
flip
containsProperty
"exitUrl"
.
getProperties
)
unlessLayer
(
`
containsProperty
`
"exitUrl"
)
$
complain
"The map must contain at least one layer with the property
\"
exitUrl
\"
set."
-- reject maps not suitable for workadventure
...
...
@@ -195,31 +195,26 @@ checkLayer = do
"group"
->
pure
()
"objectgroup"
->
do
-- all objects which
ca
n't define badges
, i.e. only texts
-- all objects which
do
n't define badges
publicObjects
<-
askContext
<&>
fmap
(
V
.
filter
(
\
case
{
ObjectText
{}
->
True
;
_
->
False
}
))
.
layerObjects
fmap
(
V
.
filter
(
`
containsProperty
`
"getBadge"
))
.
layerObjects
-- filter everything out that might define badges, but keep text
-- objects, which workadventure apparently supports but doesn't
-- really tell anyone about.
-- remove badges from output
adjust
$
\
l
->
l
{
layerObjects
=
publicObjects
,
layerProperties
=
Nothing
}
-- check object properties
forM_
(
fromMaybe
mempty
(
layerObjects
layer
))
$
\
object
->
do
mapM_
(
checkObjectProperty
object
)
(
getProperties
object
)
-- check layer properties
forM_
(
getProperties
layer
)
checkObjectGroupProperty
unless
(
layerName
layer
==
"floorLayer"
)
$
unlessHasProperty
"getBadge"
$
when
(
null
publicObjects
||
publicObjects
==
Just
mempty
)
$
warn
"objectgroup layer (which aren't the floor layer)
\
\
are useless if they do not contain the
\"
getBadge
\"
\
\
property and define at least one area for this badge,
\
\
or do not contain at least one text element."
-- individual objects can't have properties
forM_
(
fromMaybe
mempty
(
layerObjects
layer
))
$
\
object
->
unless
(
null
(
objectProperties
object
))
$
warn
"Properties cannot be set on individual objects. For
\
\
setting badge tokens, use per-layer properties instead."
warn
"objectgroup layer (which aren't the floorLayer)
\
\
are useless if they are empty."
forM_
(
getProperties
layer
)
checkObjectGroupProperty
ty
->
complain
$
"unsupported layer type "
<>
prettyprint
ty
<>
"."
if
layerType
layer
==
"group"
...
...
@@ -228,16 +223,17 @@ checkLayer = do
else
when
(
isJust
(
layerLayers
layer
))
$
complain
"Layer is not of type
\"
group
\"
, but has sublayers."
-- | Checks a single (custom) property of an objectgroup layer
checkObjectGroupProperty
::
Property
->
LintWriter
Layer
checkObjectGroupProperty
p
@
(
Property
name
_
)
=
case
name
of
"getBadge"
->
checkObjectProperty
::
Object
->
Property
->
LintWriter
Layer
checkObjectProperty
obj
p
@
(
Property
name
_
)
=
case
name
of
"url"
->
pure
()
"allowApi"
->
forbidProperty
name
"getBadge"
->
do
when
(
1
/=
length
(
getProperties
obj
))
$
warn
"Objects with the property
\"
getBadge
\"
set are removed at runtime,
\
\
and any other properties set on them will be gone."
unwrapString
p
$
\
str
->
unwrapBadgeToken
str
$
\
token
->
do
layer
<-
askContext
forM_
(
fromMaybe
(
V
.
fromList
[]
)
$
layerObjects
layer
)
$
\
object
->
do
case
object
of
case
obj
of
ObjectPoint
{
..
}
->
offersBadge
(
Badge
token
(
BadgePoint
objectX
objectY
))
ObjectRectangle
{
..
}
->
...
...
@@ -248,7 +244,13 @@ checkObjectGroupProperty p@(Property name _) = case name of
ObjectPolygon
{}
->
complain
"polygons are not supported."
ObjectPolyline
{}
->
complain
"polylines are not supported."
ObjectText
{}
->
complain
"cannot use texts to define badge areas."
_
->
warn
$
"unknown property "
<>
prettyprint
name
<>
" for objectgroup layers"
_
->
warn
$
"unknown object property "
<>
prettyprint
name
<>
"."
-- | Checks a single (custom) property of an objectgroup layer
checkObjectGroupProperty
::
Property
->
LintWriter
Layer
checkObjectGroupProperty
(
Property
name
_
)
=
warn
$
"unknown property "
<>
prettyprint
name
<>
" for objectgroup layers"
-- | Checks a single (custom) property of a "normal" tile layer
...
...
@@ -341,7 +343,8 @@ checkTileLayerProperty p@(Property name _value) = case name of
"openTab"
->
do
isString
p
requireProperty
"openWebsite"
"url"
->
isForbidden
"url"
->
complain
"the property
\"
url
\"
defining embedded iframes must be
\
\
set on an object in an objectgroup layer."
"allowApi"
->
isForbidden
"exitUrl"
->
do
forbidEmptyLayer
...
...
@@ -455,9 +458,9 @@ unlessHasProperty name linter =
unlessElementNamed
(
getProperties
ctxt
)
name
linter
-- | does this layer have the given property?
containsProperty
::
Foldable
t
=>
t
Property
->
Text
->
Bool
containsProperty
props
name
=
any
(
\
(
Property
name'
_
)
->
name'
==
name
)
props
containsProperty
::
HasProperties
a
=>
a
->
Text
->
Bool
containsProperty
thing
name
=
any
(
\
(
Property
name'
_
)
->
name'
==
name
)
(
getProperties
thing
)
-- | should the layers fulfilling the given predicate collide, then perform andthen.
whenLayerCollisions
...
...
This diff is collapsed.
Click to expand it.
lib/TiledAbstract.hs
+
5
−
1
View file @
8082e9ef
...
...
@@ -7,7 +7,7 @@ import Data.Proxy (Proxy)
import
Data.Text
(
Text
)
import
qualified
Data.Vector
as
V
import
Tiled
(
Layer
(
..
),
Property
(
..
),
PropertyValue
(
..
),
Tile
(
..
),
Tiledmap
(
..
),
Tileset
(
..
))
Tile
(
..
),
Tiledmap
(
..
),
Tileset
(
..
),
Object
(
..
))
class
HasProperties
a
where
getProperties
::
a
->
[
Property
]
...
...
@@ -28,6 +28,10 @@ instance HasProperties Tile where
adjustProperties
f
tile
=
tile
{
tileProperties
=
(
fmap
V
.
fromList
.
f
)
(
getProperties
tile
)
}
instance
HasProperties
Object
where
getProperties
=
V
.
toList
.
fromMaybe
mempty
.
objectProperties
adjustProperties
f
obj
=
obj
{
objectProperties
=
(
fmap
V
.
fromList
.
f
)
(
getProperties
obj
)
}
instance
HasProperties
Tiledmap
where
getProperties
=
fromMaybe
mempty
.
tiledmapProperties
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment