diff --git a/lib/Badges.hs b/lib/Badges.hs
index 0369334e7a41334091a146b817ffddfced6470f9..b78f08dc124d74379bb68ca6a47c86c845a815c4 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 359452c3344c603ad84a9a17fcccbff90b674a56..779123d127e090bacac132b399eb5e65cf5e1e44 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 e235fca8c20b94d2c153e5b1e72cf1db55079c4b..12c431145cb4f65846548199abd9fe955d91fa80 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 d65c9da27af1fbdc08474dbb8707b051dd1a71fb..a9bf11363a40f2f34b6a2c64bae21a29ae08f42b 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 44f2db7249f4ad6b24267048ff80ceaf73d05910..9df52d3935b9cd8f2100789d23d5922b2c86d0f3 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 0000000000000000000000000000000000000000..f7bbbb9a065221c9fc1fede1feb7edc554f4b765
--- /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 c082bfe8d65f9d274adf7b4b9a338886b732bd1d..e676e7ec2293749d8360ac72bb6f08d1f9e7aa3d 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 89096e43377ada3c6cf64bf425d51f04b4ee59c4..e39e9e37f1d3c576e8984279af59c232faa51e44 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