diff options
Diffstat (limited to 'lib/Properties.hs')
| -rw-r--r-- | lib/Properties.hs | 79 |
1 files changed, 38 insertions, 41 deletions
diff --git a/lib/Properties.hs b/lib/Properties.hs index 87b2a28..5d9c094 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -1,18 +1,21 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -- | Contains checks for custom ties of the map json module Properties (checkMap, checkTileset, checkLayer) where +import Universum hiding (intercalate, isPrefixOf) -import Control.Monad (forM, forM_, unless, when) -import Data.Text (Text, intercalate, isInfixOf, isPrefixOf) +import Data.Text (intercalate, isInfixOf, isPrefixOf) import qualified Data.Text as T import qualified Data.Vector as V import Tiled (Layer (..), Object (..), Property (..), @@ -21,19 +24,14 @@ import Tiled (Layer (..), Object (..), Property (..), import TiledAbstract (HasName (..), HasProperties (..), HasTypeName (..), IsProperty (..)) import Util (layerIsEmpty, mkProxy, naiveEscapeHTML, - prettyprint, showText) + prettyprint) import Badges (Badge (Badge), BadgeArea (BadgePoint, BadgeRect), BadgeToken, parseToken) -import Data.Data (Proxy (Proxy)) -import Data.Functor ((<&>)) import Data.List ((\\)) -import Data.Maybe (fromMaybe, isJust) -import Data.Set (Set) import qualified Data.Set as S import Data.Text.Metrics (damerauLevenshtein) -import Data.Vector (Vector) import GHC.TypeLits (KnownSymbol) import LayerData (Collision, layerOverlaps) import LintConfig (LintConfig (..)) @@ -85,7 +83,7 @@ checkMap = do let unlessLayer = unlessElement layers -- test custom map properties - mapM_ checkMapProperty (fromMaybe mempty $ tiledmapProperties tiledmap) + mapM_ checkMapProperty (maybeToMonoid $ tiledmapProperties tiledmap) -- can't have these with the rest of layer/tileset lints since they're -- not specific to any one of them @@ -143,10 +141,10 @@ checkMapProperty p@(Property name _) = case name of -- scripts can be used by one map _ | T.toLower name == "script" -> unwrapString p $ \str -> - unless ((checkIsRc3Url str) && - (not $ "/../" `isInfixOf` str) && - (not $ "%" `isInfixOf` str) && - (not $ "@" `isInfixOf` str)) + unless (checkIsRc3Url str && + not ( "/../" `isInfixOf` str) && + not ( "%" `isInfixOf` str) && + not ( "@" `isInfixOf` str)) $ forbid "only scripts hosted on static.rc3.world are allowed." | name `elem` ["jitsiRoom", "bbbRoom", "playAudio", "openWebsite" , "url", "exitUrl", "silent", "getBadge"] @@ -185,7 +183,7 @@ checkTileset = do $ complain "The \"filename\" property on tilesets was removed; use \"image\" instead (and perhaps a newer version of the Tiled Editor)." -- check individual tileset properties - mapM_ checkTilesetProperty (fromMaybe mempty $ tilesetProperties tileset) + mapM_ checkTilesetProperty (maybeToMonoid $ tilesetProperties tileset) case tilesetTiles tileset of Nothing -> pure () @@ -193,7 +191,7 @@ checkTileset = do -- can't set properties on the same tile twice refuseDoubledThings tileId (\tile -> complain $ "cannot set properties on the \ - \tile with the id" <> showText (tileId tile) <> "twice.") + \tile with the id" <> show (tileId tile) <> "twice.") tiles mapM_ checkTile tiles @@ -217,7 +215,7 @@ checkTileset = do \not an individual tile." _ -> warnUnknown' ("unknown tile property " <> prettyprint name <> " in tile with global id " - <> showText (tileId tile)) p knownTilesetProperties + <> show (tileId tile)) p knownTilesetProperties -- | collect lints on a single map layer @@ -252,14 +250,14 @@ checkLayer = do forM_ (getProperties layer) checkObjectGroupProperty unless (layerName layer == "floorLayer") $ - when (null (layerObjects layer) || layerObjects layer == Just mempty) $ + when (isNothing (layerObjects layer) || layerObjects layer == Just mempty) $ warn "objectgroup layer (which aren't the floorLayer) \ \are useless if they are empty." ty -> complain $ "unsupported layer type " <> prettyprint ty <> "." if layerType layer == "group" - then when (null (layerLayers layer)) + then when (isNothing (layerLayers layer)) $ warn "Empty group layers are pointless." else when (isJust (layerLayers layer)) $ complain "Layer is not of type \"group\", but has sublayers." @@ -310,7 +308,7 @@ checkObjectProperty p@(Property name _) = do unless (objectType obj == "variable") $ complain $ "the "<>prettyprint name<>" property should only be set \ \on objects of type \"variable\"" - when (null (objectName obj) || objectName obj == Just mempty) $ + when (isNothing (objectName obj) || objectName obj == Just mempty) $ complain $ "Objects with the property "<>prettyprint name<>" set must \ \be named." | name `elem` [ "openSound", "closeSound", "bellSound", "loadSound" ] -> do @@ -504,7 +502,7 @@ checkTileLayerProperty p@(Property name _value) = case name of requireProperty req = propertyRequiredBy req name requireOneOf names = do context <- askContext - when (all (not . containsProperty context) names) + unless (any (containsProperty context) names) $ complain $ "property " <> prettyprint name <> " requires one of " <> prettyprint names @@ -528,9 +526,8 @@ checkTileLayerProperty p@(Property name _value) = case name of -- | refuse doubled names in everything that's somehow a collection of names refuseDoubledNames - :: (HasName a, HasTypeName a) - => (Foldable t, Functor t) - => t a + :: (Container t, HasName (Element t), HasTypeName (Element t)) + => t -> LintWriter b refuseDoubledNames = refuseDoubledThings getName @@ -539,10 +536,10 @@ refuseDoubledNames = refuseDoubledThings -- | refuse doubled things via equality on after applying some function refuseDoubledThings - :: (Eq a, Ord a, Foldable t, Functor t) - => (a' -> a) - -> (a' -> LintWriter b) - -> t a' + :: (Eq a, Ord a, Container t) + => (Element t -> a) + -> (Element t -> LintWriter b) + -> t -> LintWriter b refuseDoubledThings f ifDouble things = foldr folding base things (mempty, mempty) where @@ -570,15 +567,15 @@ warnUnknown p@(Property name _) = ---- General functions ---- unlessElement - :: Foldable f - => f a - -> (a -> Bool) + :: Container f + => f + -> (Element f -> Bool) -> LintWriter b -> LintWriter b unlessElement things op = unless (any op things) -unlessElementNamed :: (HasName a, Foldable f) - => f a -> Text -> LintWriter b -> LintWriter b +unlessElementNamed :: (HasName (Element f), Container f) + => f -> Text -> LintWriter b -> LintWriter b unlessElementNamed things name = unlessElement things ((==) name . getName) @@ -756,4 +753,4 @@ isOrdInRange :: (Ord a, Show a) isOrdInRange unwrapa l r p@(Property name _) = unwrapa p $ \int -> if l < int && int < r then pure () else complain $ "Property " <> prettyprint name <> " should be between " - <> showText l <> " and " <> showText r<>"." + <> show l <> " and " <> show r<>"." |