From f3d0f937f8b5ae09a5a175daf72fda253627a116 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Wed, 22 Dec 2021 19:34:52 +0100 Subject: shorten Properties.hs down almost 100 lines of code! (and hopefully denotationally equivalent, except for the bits about where it was wrong before and didn't replace uris correctly) --- lib/Properties.hs | 228 ++++++++++++++++++------------------------------------ 1 file changed, 76 insertions(+), 152 deletions(-) diff --git a/lib/Properties.hs b/lib/Properties.hs index 62cb4f7..6f53c48 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -10,7 +10,7 @@ module Properties (checkMap, checkTileset, checkLayer) where -import Control.Monad (forM_, unless, when) +import Control.Monad (forM_, unless, when, forM) import Data.Text (Text, intercalate, isPrefixOf) import qualified Data.Text as T import qualified Data.Vector as V @@ -26,7 +26,6 @@ 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) @@ -36,7 +35,7 @@ import LayerData (Collision, layerOverlaps) import LintConfig (LintConfig (..)) import LintWriter (LintWriter, adjust, askContext, askFileDepth, complain, dependsOn, forbid, lintConfig, - offersBadge, offersEntrypoint, suggest, warn) + offersBadge, offersEntrypoint, suggest, warn, zoom) import Paths (PathResult (..), RelPath (..), getExtension, isOldStyle, parsePath) import Types (Dep (Link, Local, LocalMap, MapLink)) @@ -197,18 +196,20 @@ checkLayer = do "group" -> pure () "objectgroup" -> do + + -- check object properties + objs <- forM (layerObjects layer) $ mapM $ \object -> do + -- this is a confusing constant zoom ... + zoom (const layer) (const object) $ mapM_ checkObjectProperty (getProperties object) + adjust (\l -> l { layerObjects = objs }) + -- all objects which don't define badges - publicObjects <- askContext <&> - fmap (V.filter (not . (`containsProperty` "getBadge"))) . layerObjects + let publicObjects = fmap (V.filter (not . (`containsProperty` "getBadge"))) objs -- 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 @@ -225,15 +226,14 @@ checkLayer = do else when (isJust (layerLayers layer)) $ complain "Layer is not of type \"group\", but has sublayers." -checkObjectProperty :: Object -> Property -> LintWriter Layer -checkObjectProperty obj p@(Property name _) = case name of +checkObjectProperty :: Property -> LintWriter Object +checkObjectProperty p@(Property name _) = do + obj <- askContext + case name of "url" -> do - unwrapURI' (Proxy @"website") p + unwrapURI (Proxy @"website") p (dependsOn . Link) (const $ forbid "using \"url\" to open local html files is disallowed.") - - -- | TODO: The uri should be rewritten if the unwrapURI' did add the wrapper - unless (objectType obj == "website") $ complain "\"url\" can only be set for objects of type \"website\"" "allowApi" -> forbidProperty name @@ -255,79 +255,40 @@ checkObjectProperty obj p@(Property name _) = case name of (Just w, Just h) | w /= 0 && h /= 0 -> BadgeRect objectX objectY w h _ -> BadgePoint objectX objectY - - -- | these properties are used by the extended script to allow doors - "door" -> do - isBool p - unless (objectType obj == "variable") $ - complain "the \"door\" property should only be set on objects of type \"variable\"" - when (null (objectName obj) || objectName obj == Just mempty) $ - complain "Door variables objects must have a name given" - - "default" -> do - isBool p - suggestProperty "door" - "persist" -> do - isBool p - suggestProperty "door" - "openLayer" -> do - isString p - suggestProperty "door" - "closeLayer" -> do - isString p - suggestProperty "door" - "openSound" -> do - isString p - - unwrapURI' (Proxy @"audio") p - (dependsOn . Link) - (dependsOn . Local) - - unless (containsProperty obj "soundRadius") $ - suggest "set \"soundRadius\" to a limit the door sound to a certain area\"." - - suggestProperty "door" - "closeSound" -> do - isString p - - unwrapURI' (Proxy @"audio") p - (dependsOn . Link) - (dependsOn . Local) - - unless (containsProperty obj "soundRadius") $ - -- Do not suggest again if already suggested for openSound - unless (containsProperty obj "openSound") $ - suggest "set \"soundRadius\" to a limit the door sound to a certain area\"." - - suggestProperty "door" - - -- | these properties are used by the extended script to allow doors - "bell" -> do - isBool p - unless (objectType obj == "variable") $ - complain "the \"bell\" property should only be set on objects of type \"variable\"" - when (null (objectName obj) || objectName obj == Just mempty) $ - complain "Bell variables objects must have a name given" - "bellSound" -> do - isString p - - unwrapURI' (Proxy @"audio") p - (dependsOn . Link) - (dependsOn . Local) - - suggestProperty "bell" - - -- | Applies to doors and bells as well "soundRadius" -> do - isInt p - -- | maybe we should lint that this property is only used on door and bell variables - - - _ -> warn $ "unknown object property " <> prettyprint name <> "." - where - suggestProperty req = do - unless (containsProperty obj req) $ - suggest( "property " <> prettyprint req <> " is suggested for property " <> prettyprint name <> ".") + isIntInRange 0 maxBound p + unless (containsProperty obj "door" || containsProperty obj "bell") + $ complain "property \"soundRadius\" can only be set on objects with \ + \either property \"bell\" or \"door\" also set." + + _ | name `elem` [ "default", "persist", "openLayer", "closeLayer" ] -> do + isBool p + suggestPropertyName' "door" + -- extended API for doors and bells + | name `elem` ["door", "bell"] -> do + isBool p + 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) $ + complain $ "Objects with the property "<>prettyprint name<>" set must \ + \be named." + | name `elem` [ "openSound", "closeSound", "bellSound" ] -> do + isString p + unwrapURI (Proxy @"audio") p + (dependsOn . Link) + (dependsOn . Local) + case name of + "bellSound" -> + suggestPropertyName' "bell" + "closeSound" | containsProperty obj "openSound" -> + suggestPropertyName' "door" + _ -> do + suggestPropertyName' "door" + suggestPropertyName "soundRadius" + "set \"soundRadius\" to limit the door sound to a certain area." + | otherwise -> + warn $ "unknown object property " <> prettyprint name <> "." -- | Checks a single (custom) property of an objectgroup layer checkObjectGroupProperty :: Property -> LintWriter Layer @@ -472,56 +433,22 @@ checkTileLayerProperty p@(Property name _value) = case name of "getBadge" -> complain "\"getBadge\" must be set on an \"objectgroup\" \ \ layer; it does not work on tile layers." - -- | these properties are used by the extended script to allow doors + -- extended API stuff "zone" -> do isString p uselessEmptyLayer - "doorVariable" -> do - isString p - requireProperty "zone" - "autoOpen" -> do - isBool p - requireProperty "doorVariable" - "autoClose" -> do - isBool p - requireProperty "doorVariable" - "code" -> do - isString p - requireProperty "doorVariable" - "openTriggerMessage" -> do - isString p - requireProperty "doorVariable" - "closeTriggerMessage" -> do - isString p - requireProperty "doorVariable" - - -- | these properties are used by the extended script to allow bells - - "bellVariable" -> do - isString p - requireProperty "zone" - "bellButtonText" -> do - isString p - requireProperty "bellVariable" - "bellPopup" -> do - isString p - requireProperty "bellVariable" - - -- | these properties are used by the extended script to allow action zones¶ - "bindVariable" -> do - isString p - requireProperty "zone" - "enterValue" -> do - isString p - requireProperty "bindVariable" - "leaveValue" -> do - isString p - requireProperty "bindVariable" - - -- name on tile layer unsupported "name" -> isUnsupported - _ -> + _ | name `elem` [ "doorVariable", "bindVariable", "bellVariable" ] + -> do { isString p; requireProperty "zone" } + | name `elem` [ "autoOpen", "autoClose", "code" + , "openTriggerMessage", "closeTriggerMessage"] + -> do { isString p; requireProperty "doorVariable" } + | name `elem` [ "bellButtonText", "bellPopup" ] + -> do { isString p; requireProperty "bellVariable" } + | name `elem` [ "enterValue", "leaveValue" ] + -> do { isString p; requireProperty "bindVariable" } + | otherwise -> warn $ "unknown property type " <> prettyprint name where isForbidden = forbidProperty name @@ -613,7 +540,7 @@ whenLayerCollisions layers f andthen = do ----- Functions with concrete lint messages ----- -- | this property is forbidden and should not be used -forbidProperty :: Text -> LintWriter Layer +forbidProperty :: HasProperties a => Text -> LintWriter a forbidProperty name = do forbid $ "property " <> prettyprint name <> " is disallowed." @@ -625,12 +552,21 @@ propertyRequiredBy req by = -- | suggest some value for another property if that property does not -- also already exist -suggestProperty :: Property -> LintWriter Layer -suggestProperty (Property name value) = - unlessHasProperty name - $ suggest $ "set property " <> prettyprint name <> " to \"" <> prettyprint value<>"\"." +suggestProperty :: HasProperties a => Property -> LintWriter a +suggestProperty p@(Property name value) = + suggestProperty' p $ "set property " <> prettyprint name <> " to \"" <> prettyprint value<>"\"." + +suggestProperty' :: HasProperties a => Property -> Text -> LintWriter a +suggestProperty' (Property name _) msg = + unlessHasProperty name (suggest msg) +suggestPropertyName :: HasProperties a => Text -> Text -> LintWriter a +suggestPropertyName name msg = + unlessHasProperty name (suggest msg) +suggestPropertyName' :: HasProperties a => Text -> LintWriter a +suggestPropertyName' name = suggestPropertyName name + $ "consider setting property " <> prettyprint name <> "." ---- Functions for adjusting the context ----- @@ -701,16 +637,17 @@ unwrapBadgeToken str f = case parseToken str of -- | unwraps a URI -unwrapURI' :: (KnownSymbol s) +unwrapURI :: (KnownSymbol s, HasProperties a) => Proxy s -> Property -> (Text -> LintWriter a) -> (RelPath -> LintWriter a) -> LintWriter a -unwrapURI' sym p@(Property name _) f g = unwrapString p $ \link -> do +unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do subst <- lintConfig configUriSchemas case applySubst sym subst link of Right uri -> do + setProperty name uri f uri Left NotALink -> unwrapPath link g Left err -> complain $ case err of @@ -726,15 +663,6 @@ unwrapURI' sym p@(Property name _) f g = unwrapString p $ \link -> do <> intercalate ", " (fmap (<> "://") allowed) <> "." VarsDisallowed -> "extended API links are disallowed in links" --- | unwraps a URI and adjusts the linter's output -unwrapURI :: (KnownSymbol s, HasProperties a) - => Proxy s - -> Property - -> (Text -> LintWriter a) - -> (RelPath -> LintWriter a) - -> LintWriter a -unwrapURI sym p@(Property name _) f = - unwrapURI' sym p $ \uri -> setProperty name uri >> f uri -- | just asserts that this is a string @@ -745,10 +673,6 @@ isString = flip unwrapString (const $ pure ()) isBool :: Property -> LintWriter a isBool = flip unwrapBool (const $ pure ()) --- | just asserts that this is a int -isInt:: Property -> LintWriter a -isInt = flip unwrapInt (const $ pure ()) - isIntInRange :: Int -> Int -> Property -> LintWriter b isIntInRange = isOrdInRange @Int unwrapInt -- cgit v1.2.3