diff --git a/lib/Badges.hs b/lib/Badges.hs
new file mode 100644
index 0000000000000000000000000000000000000000..0369334e7a41334091a146b817ffddfced6470f9
--- /dev/null
+++ b/lib/Badges.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | module defining Badge types and utility functions
+module Badges where
+
+import Data.Aeson (Options (fieldLabelModifier, sumEncoding),
+ SumEncoding (UntaggedValue), ToJSON (toJSON),
+ defaultOptions, genericToJSON, (.=))
+import qualified Data.Aeson as A
+import Data.Char (toLower)
+import Data.Text (Text)
+import GHC.Generics (Generic)
+import Text.Regex.TDFA ((=~))
+
+
+data BadgeArea =
+ BadgePoint
+ { areaX :: Double
+ , areaY :: Double
+ }
+ | BadgeRect
+ { areaX :: Double
+ , areaY :: Double
+ , areaWidth :: Double
+ , areaHeight :: Double
+ , areaIsEllipse :: Bool
+ }
+ deriving (Ord, Eq, Generic, Show)
+
+newtype BadgeToken = BadgeToken Text
+ deriving (Eq, Ord, Show)
+
+instance ToJSON BadgeArea where
+ toJSON = genericToJSON defaultOptions
+ { fieldLabelModifier = drop 4 . map toLower
+ , sumEncoding = UntaggedValue }
+
+instance ToJSON BadgeToken where
+ toJSON (BadgeToken text) = toJSON text
+
+parseToken :: Text -> Maybe BadgeToken
+parseToken text = if text =~ ("^[a-zA-Z0-9]{50}$" :: Text) -- TODO: add character limit
+ then Just (BadgeToken text)
+ else Nothing
+
+data Badge = Badge BadgeToken BadgeArea
+ deriving (Ord, Eq, Generic, Show)
+
+badgeJsonArray :: A.KeyValue a => Badge -> [a]
+badgeJsonArray (Badge token area) =
+ [ "token" .= token ] <> areaObject
+ where areaObject = case area of
+ BadgePoint x y -> [ "x" .= x
+ , "y" .= y
+ , "type" .= A.String "point"
+ ]
+ BadgeRect {..} -> [ "x" .= areaX
+ , "y" .= areaY
+ , "width" .= areaWidth
+ , "height" .= areaHeight
+ , "type" .= if areaIsEllipse
+ then A.String "ellipse"
+ else A.String "rectangle"
+ ]
+
+badgeJson :: FilePath -> Badge -> A.Value
+badgeJson mappath badge = A.object (badgeJsonArray badge <> [ "map" .= mappath ])
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index d5ea44023b1dd95ff80ab612ef9329c5ad8eb6dd..17c6f78618e0c6ae3fc2ad03ce75fa85a09918e4 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -16,7 +16,7 @@ import Data.Aeson (ToJSON, (.=))
import qualified Data.Aeson as A
import Data.Foldable (fold)
import Data.Functor ((<&>))
-import Data.Map (Map, elems, keys)
+import Data.Map (Map, elems, keys, mapWithKey)
import qualified Data.Map as M
import Data.Map.Strict (mapKeys, (\\))
import Data.Maybe (mapMaybe)
@@ -32,6 +32,7 @@ import System.FilePath.Posix (takeDirectory)
import Types (Dep (Local, LocalMap), Level (..),
hintLevel)
import Util (PrettyPrint (prettyprint))
+import Badges (badgeJson)
-- based on the startling observation that Data.Map has lower complexity
@@ -94,7 +95,12 @@ instance ToJSON DirResult where
]
, "resultText" .= prettyprint (Suggestion, res)
, "severity" .= maximumLintLevel res
+ , "badges" .= annotatedBadges
]
+ where annotatedBadges = concat
+ . M.elems
+ . mapWithKey (\k -> fmap (badgeJson k) . mapresultBadges)
+ $ dirresultMaps res
instance ToJSON MissingAsset where
toJSON (MissingAsset md) = A.object
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 8a2ad7eddc7dab83a5d9dcec4660eff0ce83ac3c..359452c3344c603ad84a9a17fcccbff90b674a56 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -21,11 +21,12 @@ import qualified Data.Vector as V
import GHC.Generics (Generic)
+import Badges (Badge)
import LintConfig (LintConfig')
-import LintWriter (LintResult (..), filterLintLevel,
- invertLintResult, lintToDep,
- resultToAdjusted, resultToDeps,
- resultToLints, resultToOffers, runLintWriter)
+import LintWriter (LintResult (..), invertLintResult, lintToDep,
+ resultToAdjusted, resultToBadges,
+ resultToDeps, resultToLints, resultToOffers,
+ runLintWriter)
import Properties (checkLayer, checkMap, checkTileset)
import Tiled2 (HasName (getName),
Layer (layerLayers, layerName),
@@ -33,7 +34,7 @@ import Tiled2 (HasName (getName),
Tiledmap (tiledmapLayers, tiledmapTilesets),
Tileset, loadTiledmap)
import Types (Dep, Hint (Hint, hintLevel, hintMsg),
- Level (..), Lint (..), hint, lintsToHints)
+ Level (..), lintsToHints)
import Util (PrettyPrint (prettyprint), prettyprint)
@@ -50,6 +51,8 @@ data MapResult = MapResult
-- ^ entrypoints provided by this map (needed for dependency checking)
, mapresultAdjusted :: Maybe Tiledmap
-- ^ the loaded map, with adjustments by the linter
+ , mapresultBadges :: [Badge]
+ -- ^ badges that can be found on this map
, mapresultGeneral :: [Hint]
-- ^ general-purpose lints that didn't fit anywhere else
} deriving (Generic)
@@ -77,7 +80,7 @@ instance ToJSON CollectedLints where
-- layers upwards in the file hierarchy
loadAndLintMap :: LintConfig' -> FilePath -> Int -> IO (Maybe MapResult)
loadAndLintMap config path depth = loadTiledmap path <&> (\case
- DecodeErr err -> Just (MapResult mempty mempty mempty mempty Nothing
+ DecodeErr err -> Just (MapResult mempty mempty mempty mempty Nothing mempty
[ Hint Fatal . T.pack $
path <> ": Fatal: " <> err
])
@@ -96,6 +99,8 @@ runLinter config tiledmap depth = MapResult
<> concatMap resultToDeps tileset
, mapresultProvides = concatMap resultToOffers layer
, mapresultAdjusted = Just adjustedMap
+ , mapresultBadges = concatMap resultToBadges layer
+ <> resultToBadges generalResult
}
where
layer = checkLayerRec config depth (V.toList $ tiledmapLayers tiledmap)
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index c8ab6d5a0131670769ad492d7ca1e1ec6ba5d2b4..e235fca8c20b94d2c153e5b1e72cf1db55079c4b 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -24,6 +24,7 @@ import Data.Maybe (mapMaybe)
import qualified Data.Text as T
import Util (PrettyPrint (..))
+import Badges (Badge)
import LintConfig (LintConfig')
import Tiled2 (HasName)
import Types
@@ -87,6 +88,11 @@ resultToOffers (LintResult a) = mapMaybe lintToOffer $ snd a
resultToLints :: LintResult a -> [Lint]
resultToLints (LintResult res) = snd res
+resultToBadges :: LintResult a -> [Badge]
+resultToBadges (LintResult a) = mapMaybe lintToBadge $ snd a
+ where lintToBadge (Badge badge) = Just badge
+ lintToBadge _ = Nothing
+
resultToAdjusted :: LintResult a -> a
resultToAdjusted (LintResult res) = fst res
@@ -110,6 +116,9 @@ dependsOn dep = tell' $ Depends dep
offersEntrypoint :: Text -> LintWriter a
offersEntrypoint text = tell' $ Offers text
+offersBadge :: Badge -> LintWriter a
+offersBadge badge = tell' $ Badge badge
+
-- | adjusts the context. Gets a copy of the /current/ context, i.e. one which might
-- have already been changed by other lints
adjust :: (a -> a) -> LintWriter a
diff --git a/lib/Properties.hs b/lib/Properties.hs
index f78cefff6e481924ce6c684d18d1f27e0296d196..27076cb1c788337850cef5be54cba8a636ac48e7 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -1,33 +1,38 @@
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
-- | Contains checks for custom ties of the map json
-{-# LANGUAGE DataKinds #-}
module Properties (checkMap, checkTileset, checkLayer) where
-import Control.Monad (unless, when)
+import Control.Monad (forM_, unless, when)
import Data.Text (Text, isPrefixOf)
+import qualified Data.Vector as V
import Tiled2 (HasProperties (adjustProperties, getProperties),
IsProperty (asProperty), Layer (..),
- Property (..), PropertyValue (..),
+ Object (..), Property (..), PropertyValue (..),
Tiledmap (..), Tileset (..))
-import Util (layerIsEmpty, prettyprint, showText)
+import Util (layerIsEmpty, naiveEscapeHTML, prettyprint,
+ showText)
+import Badges (Badge (Badge),
+ BadgeArea (BadgePoint, BadgeRect), BadgeToken,
+ parseToken)
import Data.Data (Proxy (Proxy))
import Data.Maybe (fromMaybe, isJust)
import GHC.TypeLits (KnownSymbol)
import LintConfig (LintConfig (..))
import LintWriter (LintWriter, adjust, askContext, askFileDepth,
complain, dependsOn, forbid, lintConfig,
- offersEntrypoint, suggest, warn)
+ offersBadge, offersEntrypoint, suggest, warn)
import Paths (PathResult (..), RelPath (..), parsePath)
import Types (Dep (Link, Local, LocalMap, MapLink))
import Uris (SubstError (..), applySubst)
-import Data.Functor ((<&>))
-- | Checks an entire map for "general" lints.
@@ -133,8 +138,25 @@ checkLayer = do
case layerType layer of
"tilelayer" -> mapM_ checkLayerProperty (getProperties layer)
"group" -> pure ()
- ty -> unless (layerName layer == "floorLayer" && ty == "objectgroup")
- $ complain "only group and tilelayer are supported."
+ "objectgroup" -> do
+ -- TODO: this still retains object group layers, just empties them out.
+ -- perhaps actually delete the entire layer, since this still leaves hints
+ -- as to where badges are?
+ adjust $ \l -> l { layerObjects = Nothing, layerProperties = Nothing }
+
+ unless (layerName layer == "floorLayer") $ do
+ unlessHasProperty "getBadge"
+ $ warn "objectgrouop layer (which aren't the floor layer) are useless if not used to define badges."
+ when (null (layerObjects layer) || layerObjects layer == Just (V.fromList []))
+ $ warn "empty objectgroup layers (which aren't the floor layer) are useless."
+
+ -- individual objects can't have properties
+ forM_ (fromMaybe (V.fromList []) $ layerObjects layer) $ \object ->
+ unless (null (objectProperties object))
+ $ warn "Properties cannot be set on individual objects. For setting badge tokens, use per-layer properties instead."
+ mapM_ checkObjectGroupProperty (getProperties layer)
+ ty -> --unless (layerName layer == "floorLayer" && ty == "objectgroup")
+ complain $ "unsupported layer type " <> prettyprint ty <> "."
if layerType layer == "group"
then when (null (layerLayers layer))
@@ -143,7 +165,28 @@ checkLayer = do
$ complain "Layer is not of type \"group\", but has sublayers."
--- | Checks a single (custom) property of a layer
+-- | Checks a single (custom) property of an objectgroup layer
+checkObjectGroupProperty :: Property -> LintWriter Layer
+checkObjectGroupProperty p@(Property name _) = case name of
+ "getBadge" -> -- TODO check if all objects of this layer are allowed, then collect them
+ unwrapString p $ \str ->
+ unwrapBadgeToken str $ \token -> do
+ layer <- askContext
+ forM_ (fromMaybe (V.fromList []) $ layerObjects layer) $ \object -> do
+ case object of
+ ObjectPoint {..} ->
+ offersBadge (Badge token (BadgePoint objectX objectY))
+ ObjectRectangle {..} ->
+ offersBadge (Badge token area)
+ where area = BadgeRect
+ objectX objectY
+ objectWidth objectHeight
+ (objectEllipse == Just True)
+ ObjectPolygon {} -> complain "cannot use polygons for badges."
+ ObjectPolyline {} -> complain "cannot use polylines for badges."
+ _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers"
+
+-- | Checks a single (custom) property of a "normal" tile layer
--
-- It gets a reference to its own layer since sometimes the presence
-- of one property implies the presence or absense of another.
@@ -371,6 +414,11 @@ unwrapPath str f = case parsePath str of
UnderscoreMapLink -> complain "map links using /_/ are disallowed. Use world:// instead."
AtMapLink -> complain "map links using /@/ are disallowed. Use world:// instead."
+unwrapBadgeToken :: Text -> (BadgeToken -> LintWriter a) -> LintWriter a
+unwrapBadgeToken str f = case parseToken str of
+ Just a -> f a
+ Nothing -> complain "invalid badge token."
+
-- | just asserts that this is a string
isString :: Property -> LintWriter a
isString = flip unwrapString (const $ pure ())
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index 7924d3e171d34c102c424dfbd871a6b7fb5e6825..7e8f773f6beaded8022b65a28d7234e4f80604e2 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -36,8 +36,9 @@ aesonOptions :: Int -> Options
aesonOptions l = defaultOptions
{ omitNothingFields = True
, rejectUnknownFields = True
- -- can't be bothered to do a nixer prefix strip
+ -- can't be bothered to do a nicer prefix strip
, fieldLabelModifier = drop l . map toLower
+ , sumEncoding = UntaggedValue
}
-- | A globally indexed identifier.
@@ -97,8 +98,8 @@ instance ToJSON Property where
, "name" .= name
, "value" .= int]
-data Point = Point { pointX :: Int
- , pointY :: Int
+data Point = Point { pointX :: Double
+ , pointY :: Double
} deriving (Eq, Generic, Show)
instance FromJSON Point where
@@ -106,37 +107,74 @@ instance FromJSON Point where
instance ToJSON Point where
toJSON = genericToJSON (aesonOptions 5)
-data Object = Object { objectId :: Int
- -- ^ Incremental id - unique across all objects
- , objectWidth :: Double
- -- ^ Width in pixels. Ignored if using a gid.
- , objectHeight :: Double
- -- ^ Height in pixels. Ignored if using a gid.
- , objectName :: Maybe String
- -- ^ String assigned to name field in editor
- , objectType :: String
- -- ^ String assigned to type field in editor
- , objectProperties :: Maybe Value
- -- ^ String key-value pairs
- , objectVisible :: Maybe Bool
- -- ^ Whether object is shown in editor.
- , objectX :: Double
- -- ^ x coordinate in pixels
- , objectY :: Double
- -- ^ y coordinate in pixels
- , objectRotation :: Float
- -- ^ Angle in degrees clockwise
- , objectGid :: Maybe GlobalId
- -- ^ GID, only if object comes from a Tilemap
- , objectEllipse :: Maybe Bool
- -- ^ Used to mark an object as an ellipse
- , objectPolygon :: Maybe (Vector Point)
- -- ^ A list of x,y coordinates in pixels
- , objectPolyline :: Maybe (Vector Point)
- -- ^ A list of x,y coordinates in pixels
- , objectText :: Maybe Value
- -- ^ String key-value pairs
- } deriving (Eq, Generic, Show)
+
+-- | all kinds of objects that can occur in object layers, even
+-- | those that we don't want to allow.
+data Object = ObjectPoint
+ { objectId :: Int
+ , objectName :: Maybe String
+ , objectProperties :: Maybe (Vector Property)
+ , objectVisible :: Maybe Bool
+ , objectX :: Double
+ , objectY :: Double
+ , objectHeight :: Double
+ , objectWidth :: Double
+ , objectRotation :: Double
+ , objectGid :: Maybe GlobalId
+ , objectText :: Maybe Text
+ , objectType :: Text
+ , objectPoint :: Bool
+ }
+ | ObjectRectangle
+ { objectId :: Int
+ , objectName :: Maybe String
+ , objectProperties :: Maybe (Vector Property)
+ , objectVisible :: Maybe Bool
+ , objectX :: Double
+ , objectY :: Double
+ , objectRotation :: Double
+ , objectGid :: Maybe GlobalId
+ , objectText :: Maybe Text
+ , objectWidth :: Double
+ , objectHeight :: Double
+ , objectEllipse :: Maybe Bool
+ , objectType :: Text
+ }
+ | ObjectPolygon
+ { objectId :: Int
+ , objectName :: Maybe String
+ , objectProperties :: Maybe (Vector Property)
+ , objectVisible :: Maybe Bool
+ , objectX :: Double
+ , objectY :: Double
+ , objectRotation :: Double
+ , objectGid :: Maybe GlobalId
+ , objectText :: Maybe Text
+ , objectWidth :: Double
+ , objectHeight :: Double
+ , objectType :: Text
+ , objectPolygon :: Vector Point
+ }
+ | ObjectPolyline
+ { objectId :: Int
+ , objectName :: Maybe String
+ , objectProperties :: Maybe (Vector Property)
+ , objectVisible :: Maybe Bool
+ , objectX :: Double
+ , objectY :: Double
+ , objectRotation :: Double
+ , objectGid :: Maybe GlobalId
+ , objectText :: Maybe Text
+ , objectWidth :: Double
+ , objectType :: Text
+ , objectHeight :: Double
+ , objectPolyline :: Vector Point
+ } deriving (Eq, Generic, Show)
+
+
+
+
+
instance FromJSON Object where
parseJSON = genericParseJSON (aesonOptions 6)
@@ -150,7 +188,7 @@ data Layer = Layer { layerWidth :: Maybe Double
-- ^ Row count. Same as map height for fixed-size maps.
, layerName :: Text
-- ^ Name assigned to this layer
- , layerType :: String
+ , layerType :: Text
-- ^ “tilelayer”, “objectgroup”, or “imagelayer”
, layerVisible :: Bool
-- ^ Whether layer is shown or hidden in editor
diff --git a/lib/Types.hs b/lib/Types.hs
index 1099630298895731f7fb4854f4c2e652f5f64957..481dd225cb3897fb6e61164b2f54b0eb0611c619 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -15,6 +15,7 @@ import Data.Aeson (FromJSON, ToJSON (toJSON),
import Data.Text (Text)
import GHC.Generics (Generic)
+import Badges (Badge)
import qualified Data.Aeson as A
import Data.Maybe (mapMaybe)
import Paths (RelPath)
@@ -47,7 +48,7 @@ instance HasArguments Level where
-- | a hint comes with an explanation (and a level), or is a dependency
-- (in which case it'll be otherwise treated as an info hint)
-data Lint = Depends Dep | Offers Text | Lint Hint
+data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge
deriving (Ord, Eq, Generic, ToJSONKey)
-- | TODO: add a reasonable representation of possible urls
diff --git a/walint.cabal b/walint.cabal
index ce68a57db1852c223f67e065efb4cb938a50f881..89096e43377ada3c6cf64bf425d51f04b4ee59c4 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -37,6 +37,7 @@ library
Paths
Uris
LintConfig
+ Badges
build-depends: base,
aeson,
bytestring,