From 6cfdefc3438100ea829b1c86e790a0f2d56ec503 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Sat, 4 Dec 2021 04:33:01 +0100
Subject: [PATCH] lots of code reorganising and some deduplication
it was kinda getting messy in places.
Also found some accidental isomorphisms between types, so these are now
only one type because the consequences were getting silly.
---
lib/Badges.hs | 8 +-
lib/CheckMap.hs | 9 +-
lib/LintWriter.hs | 180 ++++++++++++++++++-------------
lib/Properties.hs | 209 ++++++++++++++++++++----------------
lib/{Tiled2.hs => Tiled.hs} | 51 +--------
lib/TiledAbstract.hs | 55 ++++++++++
lib/Util.hs | 2 +-
walint.cabal | 4 +-
8 files changed, 288 insertions(+), 230 deletions(-)
rename lib/{Tiled2.hs => Tiled.hs} (91%)
create mode 100644 lib/TiledAbstract.hs
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
similarity index 91%
rename from lib/Tiled2.hs
rename to 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
diff --git a/walint.cabal b/walint.cabal
index 89096e4..e39e9e3 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -31,7 +31,8 @@ library
CheckDir
LintWriter
Properties
- Tiled2
+ Tiled
+ TiledAbstract
Util
Types
Paths
@@ -63,7 +64,6 @@ executable walint
aeson-pretty,
bytestring,
mtl,
--- bytestring-encoding,
text
hs-source-dirs: src
default-language: Haskell2010
--
GitLab