diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Badges.hs | 8 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 9 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 180 | ||||
| -rw-r--r-- | lib/Properties.hs | 209 | ||||
| -rw-r--r-- | lib/Tiled.hs (renamed from lib/Tiled2.hs) | 51 | ||||
| -rw-r--r-- | lib/TiledAbstract.hs | 55 | ||||
| -rw-r--r-- | lib/Util.hs | 2 |
7 files changed, 286 insertions, 228 deletions
diff --git a/lib/Badges.hs b/lib/Badges.hs index 0369334..b78f08d 100644 --- a/lib/Badges.hs +++ b/lib/Badges.hs @@ -22,10 +22,10 @@ data BadgeArea = , areaY :: Double } | BadgeRect - { areaX :: Double - , areaY :: Double - , areaWidth :: Double - , areaHeight :: Double + { areaX :: Double + , areaY :: Double + , areaWidth :: Double + , areaHeight :: Double , areaIsEllipse :: Bool } deriving (Ord, Eq, Generic, Show) diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 359452c..779123d 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -14,7 +14,6 @@ import Data.Aeson.Types ((.=)) import Data.Functor ((<&>)) import Data.Map (Map, toList) import qualified Data.Map as M -import Data.Maybe (mapMaybe) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Vector as V @@ -23,16 +22,16 @@ import GHC.Generics (Generic) import Badges (Badge) import LintConfig (LintConfig') -import LintWriter (LintResult (..), invertLintResult, lintToDep, +import LintWriter (LintResult, invertLintResult, resultToAdjusted, resultToBadges, resultToDeps, resultToLints, resultToOffers, runLintWriter) import Properties (checkLayer, checkMap, checkTileset) -import Tiled2 (HasName (getName), - Layer (layerLayers, layerName), +import Tiled (Layer (layerLayers, layerName), LoadResult (..), Tiledmap (tiledmapLayers, tiledmapTilesets), Tileset, loadTiledmap) +import TiledAbstract (HasName (..)) import Types (Dep, Hint (Hint, hintLevel, hintMsg), Level (..), lintsToHints) import Util (PrettyPrint (prettyprint), prettyprint) @@ -94,7 +93,7 @@ runLinter config tiledmap depth = MapResult { mapresultLayer = invertThing layer , mapresultTileset = invertThing tileset , mapresultGeneral = lintsToHints $ resultToLints generalResult - , mapresultDepends = mapMaybe lintToDep (resultToLints generalResult) + , mapresultDepends = resultToDeps generalResult <> concatMap resultToDeps layer <> concatMap resultToDeps tileset , mapresultProvides = concatMap resultToOffers layer diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index e235fca..12c4311 100644 --- a/lib/LintWriter.hs +++ b/lib/LintWriter.hs @@ -7,11 +7,39 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} -- | a monad that collects warnings, outputs, etc, -module LintWriter where +module LintWriter + ( runLintWriter + , LintWriter + , LintWriter' + , LintResult + , invertLintResult + -- * working with lint results + , resultToDeps + , resultToOffers + , resultToBadges + , resultToLints + , resultToAdjusted + -- * Add lints to a linter + , info + , suggest + , warn + , forbid + , complain + -- * add other information to the linter + , offersEntrypoint + , offersBadge + , dependsOn + -- * get information about the linter's context + , askContext + , askFileDepth + , lintConfig + -- * adjust the linter's context + , adjust + ) where -import Data.Aeson (ToJSON (toJSON)) import Data.Text (Text) import Control.Monad.State (StateT, modify) @@ -21,123 +49,123 @@ import Control.Monad.Writer.Lazy (lift) import Data.Bifunctor (Bifunctor (second)) import Data.Map (Map, fromListWith) import Data.Maybe (mapMaybe) -import qualified Data.Text as T -import Util (PrettyPrint (..)) - import Badges (Badge) import LintConfig (LintConfig') -import Tiled2 (HasName) -import Types - --- | for now, all context we have is how "deep" in the directory tree --- we currently are -type Context = Int - -newtype LinterState ctxt = LinterState - { fromLinterState :: ([Lint], ctxt)} +import TiledAbstract (HasName) +import Types (Dep, Hint, Level (..), Lint (..), + hint, lintsToHints) --- | a monad to collect hints, with some context (usually the containing layer/etc.) +-- | A monad modelling the main linter features type LintWriter ctxt = LintWriter' ctxt () +-- | A linter that can use pure / return things monadically type LintWriter' ctxt res = StateT (LinterState ctxt) (Reader (Context, ctxt, LintConfig')) res --- wrapped to allow for manual writing of Aeson instances -type LintResult' ctxt = (ctxt, [Lint]) -- Either Lint (a, [Lint]) -newtype LintResult ctxt = LintResult (LintResult' ctxt) +-- | A Linter's state: some context (which it may adjust), and a list of lints +-- | it already collected. +newtype LinterState ctxt = LinterState + { fromLinterState :: ([Lint], ctxt)} + +-- | The result of running a linter: an adjusted context, and a list of lints. +-- | This is actually just a type synonym of LinterState, but kept seperately +-- | for largely historic reasons since I don't think I'll change it again +type LintResult ctxt = LinterState ctxt +-- | for now, all context we have is how "deep" in the directory tree +-- we currently are +type Context = Int +-- | run a linter. Returns the adjusted context, and a list of lints +runLintWriter + :: LintConfig' -> ctxt -> Context -> LintWriter ctxt -> LintResult ctxt +runLintWriter config context depth linter = LinterState + . fromLinterState + . snd + . runReader runstate + $ (depth, context, config) + where runstate = runStateT linter (LinterState ([], context)) + +-- | "invert" a linter's result, grouping lints by their messages invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [ctxt] -invertLintResult (LintResult (ctxt, lints)) = +invertLintResult (LinterState (lints, ctxt)) = fromListWith (<>) $ (, [ctxt]) <$> lintsToHints lints --- better, less confusing serialisation of an Either Hint (a, [Hint]). --- Note that Left hint is also serialised as a list to make the resulting --- json schema more regular. -instance ToJSON (LintResult a) where - toJSON (LintResult res) = toJSON $ snd res - -instance PrettyPrint ctxt => PrettyPrint (Level, LintResult ctxt) where - prettyprint (level, LintResult (ctxt, res)) = - T.concat $ map ((<> context) . prettyprint) (filterLintLevel level res) - where context = " (" <> prettyprint ctxt <> ")\n" - -lintToDep :: Lint -> Maybe Dep -lintToDep = \case - Depends dep -> Just dep - _ -> Nothing - -lintToOffer :: Lint -> Maybe Text -lintToOffer = \case - Offers frag -> Just frag - _ -> Nothing - -filterLintLevel :: Level -> [Lint] -> [Lint] -filterLintLevel level = mapMaybe $ \l -> if level <= lintLevel l - then Just l - else Nothing - resultToDeps :: LintResult a -> [Dep] -resultToDeps (LintResult a) = mapMaybe lintToDep $ snd a +resultToDeps (LinterState (lints,_)) = mapMaybe lintToDep lints + where lintToDep = \case + Depends dep -> Just dep + _ -> Nothing resultToOffers :: LintResult a -> [Text] -resultToOffers (LintResult a) = mapMaybe lintToOffer $ snd a - --- | convert a lint result into a flat list of lints --- (throwing away information on if a single error was fatal) -resultToLints :: LintResult a -> [Lint] -resultToLints (LintResult res) = snd res +resultToOffers (LinterState a) = mapMaybe lintToOffer $ fst a + where lintToOffer = \case + Offers frag -> Just frag + _ -> Nothing resultToBadges :: LintResult a -> [Badge] -resultToBadges (LintResult a) = mapMaybe lintToBadge $ snd a +resultToBadges (LinterState a) = mapMaybe lintToBadge $ fst a where lintToBadge (Badge badge) = Just badge lintToBadge _ = Nothing +-- | convert a lint result into a flat list of lints +resultToLints :: LintResult a -> [Lint] +resultToLints (LinterState res) = fst res + +-- | extract the adjusted context from a lint result resultToAdjusted :: LintResult a -> a -resultToAdjusted (LintResult res) = fst res +resultToAdjusted (LinterState res) = snd res --- | run a linter. Returns the adjusted context, and a list of lints -runLintWriter :: LintConfig' -> ctxt -> Context -> LintWriter ctxt -> LintResult ctxt -runLintWriter config c c' linter = LintResult (snd $ fromLinterState lints,fst $ fromLinterState lints) - where lints = snd $ runReader ranstate (c',c, config) - ranstate = runStateT linter (LinterState ([], c)) -tell' :: Lint -> LintWriter ctxt -tell' l = modify $ \(LinterState (lints, ctxt)) -> LinterState (l:lints, ctxt) --- | write a hint into the LintWriter monad -lint :: Level -> Text -> LintWriter a -lint level text = tell' $ hint level text +-- | fundamental linter operations: add a lint of some severity +info = lint Info +suggest = lint Suggestion +warn = lint Warning +forbid = lint Forbidden +complain = lint Error +-- | add a dependency to the linter dependsOn :: Dep -> LintWriter a dependsOn dep = tell' $ Depends dep +-- | add an offer for an entrypoint to the linter offersEntrypoint :: Text -> LintWriter a offersEntrypoint text = tell' $ Offers text +-- | add an offer for a badge to the linter 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 -adjust f = modify $ LinterState . second f . fromLinterState -info = lint Info -suggest = lint Suggestion -warn = lint Warning -forbid = lint Forbidden -complain = lint Error - - --- | get the context as it was originally, without any modifications +-- | get the context as it was initially, without any modifications askContext :: LintWriter' a a askContext = lift $ asks (\(_,a,_) -> a) +-- | ask for the file depth within the repository tree of the current map. +-- | This function brings in a lot more conceptual baggage than I'd like, but +-- | it's needed to check if relative paths lie outside the repository askFileDepth :: LintWriter' a Int askFileDepth = lift $ asks (\(a,_,_) -> a) +-- | ask for a specific part of the linter's global config lintConfig :: (LintConfig' -> a) -> LintWriter' ctxt a lintConfig get = lift $ asks (\(_,_,config) -> get config) + + + + +-- | tell, but for a singular lint. Leaves the context unchanged +tell' :: Lint -> LintWriter ctxt +tell' l = modify $ \(LinterState (lints, ctxt)) -> LinterState (l:lints, ctxt) + +-- | small helper to tell a singlular proper lint +lint :: Level -> Text -> LintWriter a +lint level text = tell' $ hint level text + +-- | adjusts the context. Gets a copy of the /current/ context, +-- | i.e. one which might have already been changed by other adjustments +adjust :: (a -> a) -> LintWriter a +adjust f = modify $ LinterState . second f . fromLinterState diff --git a/lib/Properties.hs b/lib/Properties.hs index d65c9da..a9bf113 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -13,11 +13,10 @@ module Properties (checkMap, checkTileset, checkLayer) where import Control.Monad (forM_, unless, when) import Data.Text (Text, isPrefixOf) import qualified Data.Vector as V -import Tiled2 (HasName (getName), - HasProperties (adjustProperties, getProperties), - HasTypeName (typeName), IsProperty (asProperty), - Layer (..), Object (..), Property (..), +import Tiled (Layer (..), Object (..), Property (..), PropertyValue (..), Tiledmap (..), Tileset (..)) +import TiledAbstract (HasName (..), HasProperties (..), + HasTypeName (..), IsProperty (..)) import Util (layerIsEmpty, mkProxy, naiveEscapeHTML, prettyprint, showText) @@ -39,67 +38,59 @@ import Uris (SubstError (..), applySubst) -- | Checks an entire map for "general" lints. -- --- Note that it does /not/ call checkMapProperty; this is handled --- seperately in CheckMap.hs, since these lints go into a different --- field of the resulting json. +-- Note that it does /not/ check any tile layer/tileset properties; +-- these are handled seperately in CheckMap, since these lints go +-- into a different field of the output. checkMap :: LintWriter Tiledmap checkMap = do tiledmap <- askContext + let unlessLayer = unlessElement (tiledmapLayers tiledmap) - -- test other things - mapM_ checkMapProperty (fromMaybe [] $ tiledmapProperties tiledmap) - - -- some layers should exist - hasLayerNamed "start" (const True) - "The map must have one layer named \"start\"." - hasLayerNamed "floorLayer" ((==) "objectgroup" . layerType) - "The map must have one layer named \"floorLayer\" of type \"objectgroup\"." - hasLayer (flip containsProperty "exitUrl" . getProperties) - "The map must contain at least one layer with the property \"exitUrl\" set." + -- test custom map properties + mapM_ checkMapProperty (fromMaybe mempty $ tiledmapProperties tiledmap) + -- can't have these with the rest of layer/tileset lints since they're + -- not specific to any one of them refuseDoubledNames (tiledmapLayers tiledmap) refuseDoubledNames (tiledmapTilesets tiledmap) + -- some layers should exist + unlessElementNamed (tiledmapLayers tiledmap) "start" + $ 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) + $ complain "The map must contain at least one layer with the property \"exitUrl\" set." + -- reject maps not suitable for workadventure unless (tiledmapOrientation tiledmap == "orthogonal") $ complain "The map's orientation must be set to \"orthogonal\"." unless (tiledmapTileheight tiledmap == 32 && tiledmapTilewidth tiledmap == 32) $ complain "The map's tile size must be 32 by 32 pixels." - where - hasLayerNamed name p = hasLayer (\l -> layerName l == name && p l) - hasLayer p err = do - tiledmap <- askContext - unless (any p (tiledmapLayers tiledmap)) - $ complain err - -- | Checks a single property of a map. -- -- Doesn't really do all that much, but could in theory be expanded into a -- longer function same as checkLayerProperty. checkMapProperty :: Property -> LintWriter Tiledmap -checkMapProperty p@(Property name _value) = case name of +checkMapProperty p@(Property name _) = case name of "script" -> do -- this is kind of stupid, since if we also inject script this -- will be overriden anyways, but it also doesn't really hurt I guess -- TODO: perhaps include an explanation in the lint, or allow -- exactly that one value? lintConfig configAllowScripts >>= \case - False -> isForbidden + False -> forbid "cannot use property \"script\"; custom scripts are disallowed" True -> pure () lintConfig configScriptInject >>= \case Nothing -> pure () Just url -> setProperty "script" url "mapName" -> naiveEscapeProperty p - "mapLink" -> pure () - "mapImage" -> pure () "mapDescription" -> naiveEscapeProperty p "mapCopyright" -> naiveEscapeProperty p - + "mapLink" -> pure () + "mapImage" -> pure () _ -> complain $ "unknown map property " <> prettyprint name - where - -- | this property is forbidden and should not be used - isForbidden = forbid $ "property " <> prettyprint name <> " should not be used" -- | check an embedded tile set. @@ -126,24 +117,25 @@ checkTileset = do unlessHasProperty "copyright" $ forbid "property \"copyright\" is required for tilesets." - + -- check individual tileset properties mapM_ checkTilesetProperty (fromMaybe [] $ tilesetProperties tileset) - -checkTilesetProperty :: Property -> LintWriter Tileset -checkTilesetProperty p@(Property name _value) = case name of - "copyright" -> naiveEscapeProperty p - _ -> pure () -- are there any other properties? + where + checkTilesetProperty :: Property -> LintWriter Tileset + checkTilesetProperty p@(Property name _value) = case name of + "copyright" -> naiveEscapeProperty p + _ -> warn $ "unknown tileset property " <> prettyprint name -- | collect lints on a single map layer checkLayer :: LintWriter Layer checkLayer = do layer <- askContext - when (isJust (layerImage layer)) - $ complain "imagelayer are not supported." refuseDoubledNames (getProperties layer) + when (isJust (layerImage layer)) + $ complain "imagelayer are not supported." + case layerType layer of "tilelayer" -> mapM_ checkTileLayerProperty (getProperties layer) "group" -> pure () @@ -154,18 +146,24 @@ checkLayer = do adjust $ \l -> l { layerObjects = Nothing, layerProperties = Nothing } unless (layerName layer == "floorLayer") $ do + + -- TODO: these two checks can probably be unified 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." + $ warn "objectgrouop layer (which aren't the floor layer)\ + \are useless if not used to define badges." + + when (null (layerObjects layer) || layerObjects layer == Just mempty) + $ 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 -> + 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." - mapM_ checkObjectGroupProperty (getProperties layer) - ty -> --unless (layerName layer == "floorLayer" && ty == "objectgroup") - complain $ "unsupported layer type " <> prettyprint ty <> "." + $ warn "Properties cannot be set on individual objects. For setting\ + \badge tokens, use per-layer properties instead." + + forM_ (getProperties layer) checkObjectGroupProperty + ty -> complain $ "unsupported layer type " <> prettyprint ty <> "." if layerType layer == "group" then when (null (layerLayers layer)) @@ -177,7 +175,7 @@ checkLayer = do -- | 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 + "getBadge" -> unwrapString p $ \str -> unwrapBadgeToken str $ \token -> do layer <- askContext @@ -195,10 +193,8 @@ checkObjectGroupProperty p@(Property name _) = case name of 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. checkTileLayerProperty :: Property -> LintWriter Layer checkTileLayerProperty p@(Property name _value) = case name of "jitsiRoom" -> do @@ -216,7 +212,8 @@ checkTileLayerProperty p@(Property name _value) = case name of "jitsiTrigger" -> do isString p unlessHasProperty "jitsiTriggerMessage" - $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\"." + $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite\ + \the default \"press SPACE to enter in jitsi meet room\"." requireProperty "jitsiRoom" "jitsiTriggerMessage" -> do isString p @@ -245,9 +242,10 @@ checkTileLayerProperty p@(Property name _value) = case name of unwrapString p (setProperty "openWebsiteTrigger") unlessHasProperty "bbbTriggerMessage" $ do - suggest "set \"bbbTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter the bbb room\"" setProperty "openWebsiteTriggerMessage" ("press SPACE to enter bbb room" :: Text) + suggest "set \"bbbTriggerMessage\" to a custom message to overwrite the\ + \default \"press SPACE to enter the bbb room\"" "bbbTriggerMessage" -> do removeProperty "bbbTriggerMessage" requireProperty "bbbRoom" @@ -274,9 +272,10 @@ checkTileLayerProperty p@(Property name _value) = case name of (dependsOn . Local) "openWebsiteTrigger" -> do isString p - unlessHasProperty "openWebsiteTriggerMessage" - $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the default \"press SPACE to open Website\"." requireProperty "openWebsite" + unlessHasProperty "openWebsiteTriggerMessage" + $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to\ + \overwrite the default \"press SPACE to open Website\"." "openWebsiteTriggerMessage" -> do isString p requireProperty "openWebsiteTrigger" @@ -320,12 +319,13 @@ checkTileLayerProperty p@(Property name _value) = case name of deprecatedUseInstead instead = warn $ "property \"" <> name <> "\" is deprecated. Use \"" <> instead <> "\" instead." - - -- | this property can only be used on a layer that contains at least one tiles + -- | this property can only be used on a layer that contains + -- | at least one tile forbidEmptyLayer = do layer <- askContext when (layerIsEmpty layer) $ complain ("property " <> prettyprint name <> " should not be set on an empty layer.") + -- | this layer is allowed, but also useless on a layer that contains no tiles uselessEmptyLayer = do layer <- askContext @@ -349,24 +349,45 @@ refuseDoubledNames things = foldr folding base things mempty where name = getName thing base _ = pure () ---------- Helper functions & stuff --------- + +---- General functions ---- + +unlessElement + :: Foldable f + => f a + -> (a -> 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 things name = + unlessElement things ((==) name . getName) unlessHasProperty :: HasProperties a => Text -> LintWriter a -> LintWriter a -unlessHasProperty name andthen = do - layer <- askContext - let hasprop = any (\(Property name' _) -> name == name') (getProperties layer) - unless hasprop andthen +unlessHasProperty name linter = + askContext >>= \ctxt -> + 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 + +----- Functions with concrete lint messages ----- -- | this property is forbidden and should not be used forbidProperty :: Text -> LintWriter Layer forbidProperty name = do - forbid $ "property " <> prettyprint name <> " should not be used." + forbid $ "property " <> prettyprint name <> " is disallowed." propertyRequiredBy :: HasProperties a => Text -> Text -> LintWriter a propertyRequiredBy req by = unlessHasProperty req - $ complain $ "property "<>prettyprint req<>" is required by property "<> prettyprint by<>"." + $ complain $ "property " <> prettyprint req <> + " is required by property " <> prettyprint by <> "." -- | suggest some value for another property if that property does not -- also already exist @@ -375,6 +396,11 @@ suggestProperty (Property name value) = unlessHasProperty name $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value<>"." + + +---- Functions for adjusting the context ----- + + -- | set a property, overwriting whatever value it had previously setProperty :: (IsProperty prop, HasProperties ctxt) => Text -> prop -> LintWriter ctxt @@ -388,37 +414,41 @@ removeProperty name = adjust $ \ctxt -> flip adjustProperties ctxt $ \ps -> Just $ filter (\(Property name' _) -> name' /= name) ps +naiveEscapeProperty :: HasProperties a => Property -> LintWriter a +naiveEscapeProperty prop@(Property name _) = + unwrapString prop (setProperty name . naiveEscapeHTML) --- | does this layer have the given property? -containsProperty :: Foldable t => t Property -> Text -> Bool -containsProperty props name = any - (\(Property name' _) -> name' == name) props - +---- "unwrappers" checking that a property has some type, then do something ---- -- | asserts that this property is a string, and unwraps it unwrapString :: Property -> (Text -> LintWriter a) -> LintWriter a unwrapString (Property name value) f = case value of StrProp str -> f str - _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string." + _ -> complain $ "type error: property " + <> prettyprint name <> " should be of type string." -- | same as unwrapString, but also forbids http:// as prefix unwrapLink :: Property -> (Text -> LintWriter a) -> LintWriter a unwrapLink (Property name value) f = case value of StrProp str -> if "http://" `isPrefixOf` str - then complain "cannot access content via http; either use https or include it locally instead." + then complain "cannot access content via http; either use https or include\ + \it locally in your repository instead." else f str - _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string and contain a valid uri." + _ -> complain $ "type error: property " <> prettyprint name <> " should be\ + \of type string and contain a valid uri." -- | asserts that this property is a boolean, and unwraps it unwrapBool :: Property -> (Bool -> LintWriter a) -> LintWriter a unwrapBool (Property name value) f = case value of BoolProp b -> f b - _ -> complain $ "type error: property " <> prettyprint name <> " should be of type bool." + _ -> complain $ "type error: property " <> prettyprint name + <> " should be of type bool." unwrapInt :: Property -> (Int -> LintWriter a) -> LintWriter a unwrapInt (Property name value) f = case value of IntProp float -> f float - _ -> complain $ "type error: property " <> prettyprint name <> " should be of type int." + _ -> complain $ "type error: property " <> prettyprint name + <> " should be of type int." unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a unwrapPath str f = case parsePath str of @@ -437,20 +467,6 @@ 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 ()) - --- | just asserts that this is a boolean -isBool :: Property -> LintWriter a -isBool = flip unwrapBool (const $ pure ()) - -isIntInRange :: Int -> Int -> Property -> LintWriter a -isIntInRange l r p@(Property name _) = unwrapInt p $ \int -> - if l < int && int < r then pure () - else complain $ "Property " <> prettyprint name <> " should be between" <> showText l <> " and " <> showText r<>"." - - unwrapURI :: (KnownSymbol s, HasProperties a) => Proxy s -> Property -> (Text -> LintWriter a) -> (RelPath -> LintWriter a) -> LintWriter a unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do @@ -468,6 +484,15 @@ unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do WrongScope schema -> "the URI schema " <> schema <> ":// cannot be used on \""<>name<>"\"." -naiveEscapeProperty :: HasProperties a => Property -> LintWriter a -naiveEscapeProperty prop@(Property name _) = - unwrapString prop (setProperty name . naiveEscapeHTML) +-- | just asserts that this is a string +isString :: Property -> LintWriter a +isString = flip unwrapString (const $ pure ()) + +-- | just asserts that this is a boolean +isBool :: Property -> LintWriter a +isBool = flip unwrapBool (const $ pure ()) + +isIntInRange :: Int -> Int -> Property -> LintWriter a +isIntInRange l r p@(Property name _) = unwrapInt p $ \int -> + if l < int && int < r then pure () + else complain $ "Property " <> prettyprint name <> " should be between" <> showText l <> " and " <> showText r<>"." diff --git a/lib/Tiled2.hs b/lib/Tiled.hs index 44f2db7..9df52d3 100644 --- a/lib/Tiled2.hs +++ b/lib/Tiled.hs @@ -13,7 +13,7 @@ -- cover some of the types and records that are available in the format. For -- those you should read the TMX documentation at -- http://doc.mapeditor.org/en/latest/reference/tmx-map-format/ -module Tiled2 where +module Tiled where import Control.Exception (try) import Control.Exception.Base (SomeException) @@ -24,8 +24,6 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LB import Data.Char (toLower) import Data.Map (Map) -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy) import Data.String (IsString (fromString)) import Data.Text (Text) import qualified Data.Text as T @@ -377,53 +375,6 @@ instance FromJSON Tiledmap where instance ToJSON Tiledmap where toJSON = genericToJSON (aesonOptions 8) - -class HasProperties a where - getProperties :: a -> [Property] - adjustProperties :: ([Property] -> Maybe [Property]) -> a -> a - -instance HasProperties Layer where - getProperties = fromMaybe [] . layerProperties - adjustProperties f layer = layer - { layerProperties = f (getProperties layer) } - -instance HasProperties Tileset where - getProperties = fromMaybe [] . tilesetProperties - adjustProperties f tileset = tileset - { tilesetProperties = f (getProperties tileset) } - -instance HasProperties Tiledmap where - getProperties = fromMaybe [] . tiledmapProperties - adjustProperties f tiledmap = tiledmap - { tiledmapProperties = f (getProperties tiledmap) } - -class HasTypeName a where - typeName :: Proxy a -> Text -instance HasTypeName Layer where - typeName _ = "layer" -instance HasTypeName Tileset where - typeName _ = "tileset" -instance HasTypeName Property where - typeName _ = "property" - -class HasName a where - getName :: a -> Text -instance HasName Layer where - getName = layerName -instance HasName Tileset where - getName = tilesetName -instance HasName Property where - getName (Property n _) = n - -class IsProperty a where - asProperty :: a -> PropertyValue -instance IsProperty PropertyValue where - asProperty = id - {-# INLINE asProperty #-} -instance IsProperty Text where - asProperty = StrProp - {-# INLINE asProperty #-} - data LoadResult = Loaded Tiledmap | IOErr String | DecodeErr String -- | Load a Tiled map from the given 'FilePath'. diff --git a/lib/TiledAbstract.hs b/lib/TiledAbstract.hs new file mode 100644 index 0000000..f7bbbb9 --- /dev/null +++ b/lib/TiledAbstract.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TiledAbstract where + +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy) +import Data.Text (Text) +import Tiled (Layer (..), Property (..), PropertyValue (..), + Tiledmap (..), Tileset (..)) + +class HasProperties a where + getProperties :: a -> [Property] + adjustProperties :: ([Property] -> Maybe [Property]) -> a -> a + +instance HasProperties Layer where + getProperties = fromMaybe mempty . layerProperties + adjustProperties f layer = layer + { layerProperties = f (getProperties layer) } + +instance HasProperties Tileset where + getProperties = fromMaybe mempty . tilesetProperties + adjustProperties f tileset = tileset + { tilesetProperties = f (getProperties tileset) } + +instance HasProperties Tiledmap where + getProperties = fromMaybe mempty . tiledmapProperties + adjustProperties f tiledmap = tiledmap + { tiledmapProperties = f (getProperties tiledmap) } + +class HasTypeName a where + typeName :: Proxy a -> Text +instance HasTypeName Layer where + typeName _ = "layer" +instance HasTypeName Tileset where + typeName _ = "tileset" +instance HasTypeName Property where + typeName _ = "property" + +class HasName a where + getName :: a -> Text +instance HasName Layer where + getName = layerName +instance HasName Tileset where + getName = tilesetName +instance HasName Property where + getName (Property n _) = n + +class IsProperty a where + asProperty :: a -> PropertyValue +instance IsProperty PropertyValue where + asProperty = id + {-# INLINE asProperty #-} +instance IsProperty Text where + asProperty = StrProp + {-# INLINE asProperty #-} diff --git a/lib/Util.hs b/lib/Util.hs index c082bfe..e676e7e 100644 --- a/lib/Util.hs +++ b/lib/Util.hs @@ -10,7 +10,7 @@ import Data.Aeson as Aeson import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as T -import Tiled2 (Layer (layerData), PropertyValue (..), +import Tiled (Layer (layerData), PropertyValue (..), Tileset (tilesetName), layerName, mkTiledId) -- | helper function to create proxies |