diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Badges.hs | 70 | ||||
| -rw-r--r-- | lib/CheckDir.hs | 8 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 17 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 9 | ||||
| -rw-r--r-- | lib/Properties.hs | 66 | ||||
| -rw-r--r-- | lib/Tiled2.hs | 108 | ||||
| -rw-r--r-- | lib/Types.hs | 3 |
7 files changed, 229 insertions, 52 deletions
diff --git a/lib/Badges.hs b/lib/Badges.hs new file mode 100644 index 0000000..0369334 --- /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 d5ea440..17c6f78 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 8a2ad7e..359452c 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 c8ab6d5..e235fca 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 f78ceff..27076cb 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 7924d3e..7e8f773 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 1099630..481dd22 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 |