diff options
| -rw-r--r-- | lib/LintWriter.hs | 1 | ||||
| -rw-r--r-- | lib/Properties.hs | 27 | ||||
| -rw-r--r-- | lib/Types.hs | 16 | ||||
| -rw-r--r-- | tiled-hs.cabal | 4 |
4 files changed, 27 insertions, 21 deletions
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index 120a0f5..dd5ae7d 100644 --- a/lib/LintWriter.hs +++ b/lib/LintWriter.hs @@ -64,6 +64,7 @@ lint level = tell . (: []) . hint level dependsOn :: Dep -> LintWriter () dependsOn dep = tell . (: []) $ Depends dep + warn = lint Warning info = lint Info forbid = lint Forbidden diff --git a/lib/Properties.hs b/lib/Properties.hs index c2f5c81..320f132 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -14,10 +14,10 @@ import Util (layerIsEmpty, prettyprint) import LintWriter (LintWriter, complain, dependsOn, forbid, info, suggest, warn) +import Paths import Types (Dep (Link, Local, LocalMap, MapLink)) - -- | Checks an entire map for "general" lints. -- -- Note that it does /not/ call checkMapProperty; this is handled @@ -70,7 +70,7 @@ checkMapProperty map (Property name value) = case name of checkTileset :: Tileset -> LintWriter () checkTileset tileset = do -- TODO: can tilesets be non-local dependencies? - dependsOn $ Local (tilesetImage tileset) + unwrapPath (tilesetImage tileset) (dependsOn . Local) -- reject tilesets unsuitable for workadventure unless (tilesetTilewidth tileset == 32 && tilesetTileheight tileset == 32) @@ -104,9 +104,9 @@ checkLayerProperty layer p@(Property name value) = case name of "jitsiRoomAdminTag" -> isForbidden "playAudio" -> do uselessEmptyLayer - unwrapLink p $ \link -> dependsOn $ if "https://" `isPrefixOf` link - then Link link - else Local link + unwrapLink p $ \link -> if "https://" `isPrefixOf` link + then dependsOn $ Link link + else unwrapPath link (dependsOn . Local) "audioLoop" -> do isBool p requireProp "playAudio" @@ -116,9 +116,9 @@ checkLayerProperty layer p@(Property name value) = case name of "openWebsite" -> do uselessEmptyLayer suggestProp $ Property "openWebsiteTrigger" (StrProp "onaction") - unwrapLink p $ \link -> dependsOn $ if "https://" `isPrefixOf` link - then Link link - else Local link + unwrapLink p $ \link -> if "https://" `isPrefixOf` link + then dependsOn $ Link link + else unwrapPath link (dependsOn . Local) "openWebsiteTrigger" -> do isString p unless (hasProperty "openWebsiteTriggerMessage") @@ -137,9 +137,9 @@ checkLayerProperty layer p@(Property name value) = case name of "allowApi" -> isForbidden "exitUrl" -> do forbidEmptyLayer - unwrapLink p $ \link -> dependsOn $ if "https://" `isPrefixOf` link - then MapLink link - else LocalMap link + unwrapLink p $ \link -> if "https://" `isPrefixOf` link + then dependsOn $ MapLink link + else unwrapPath link (dependsOn . LocalMap) "startLayer" -> do forbidEmptyLayer unwrapBool p $ \case @@ -206,6 +206,11 @@ unwrapBool (Property name value) f = case value of BoolProp b -> f b _ -> complain $ "type mismatch in property " <> name <> "; should be of type bool" +unwrapPath :: Text -> (RelPath -> LintWriter ()) -> LintWriter () +unwrapPath str f = case parsePath str of + Just path -> f path + Nothing -> complain $ "path \"" <> str <> "\" is invalid" + -- | just asserts that this is a string isString :: Property -> LintWriter () isString = flip unwrapString (const $ pure ()) diff --git a/lib/Types.hs b/lib/Types.hs index 2b67d47..5ec91a0 100644 --- a/lib/Types.hs +++ b/lib/Types.hs @@ -15,11 +15,9 @@ import Data.Text (Text) import GHC.Generics (Generic) import qualified Data.Aeson as A -import Tiled2 (Property (Property), - PropertyValue (BoolProp, StrProp)) +import Paths (RelPath) import Util (PrettyPrint (..), showText) - -- | Levels of errors and warnings, collectively called -- "Hints" until I can think of some better name data Level = Warning | Suggestion | Info | Forbidden | Error | Fatal @@ -30,7 +28,7 @@ data Level = Warning | Suggestion | Info | Forbidden | Error | Fatal data Lint = Depends Dep | Lint Hint -- | TODO: add a reasonable representation of possible urls -data Dep = Local Text | Link Text | MapLink Text | LocalMap Text +data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath deriving (Generic) data Hint = Hint @@ -38,7 +36,7 @@ data Hint = Hint , hintMsg :: Text } deriving (Generic, ToJSON) --- | shorter constructor (called lint because (a) older name and +-- | shorter constructor (called hint because (a) older name and -- (b) lint also exists and is monadic) hint :: Level -> Text -> Lint hint level msg = Lint Hint { hintLevel = level, hintMsg = msg } @@ -62,17 +60,17 @@ instance ToJSON Lint where instance ToJSON Dep where toJSON = \case - Local text -> json "local" text + Local text -> json "local" $ prettyprint text Link text -> json "link" text MapLink text -> json "mapservice" text - LocalMap text -> json "map" text + LocalMap text -> json "map" $ prettyprint text where json :: A.Value -> Text -> A.Value json kind text = A.object [ "kind" .= kind, "dep" .= text ] instance PrettyPrint Dep where prettyprint = \case - Local dep -> "[local dep: " <> dep <> "]" + Local dep -> "[local dep: " <> prettyprint dep <> "]" Link dep -> "[link dep: " <> dep <> "]" MapLink dep -> "[map service dep: " <> dep <> "]" - LocalMap dep -> "[local map dep: " <> dep <> "]" + LocalMap dep -> "[local map dep: " <> prettyprint dep <> "]" diff --git a/tiled-hs.cabal b/tiled-hs.cabal index 4da4a45..3740fd3 100644 --- a/tiled-hs.cabal +++ b/tiled-hs.cabal @@ -32,6 +32,7 @@ library Tiled2 Util Types + Paths build-depends: base ^>=4.14.1.0, aeson, bytestring, @@ -40,7 +41,8 @@ library vector, transformers, mtl, - either + either, + regex-tdfa ^>= 1.3.1.1 -- TODO: move more stuff into lib, these dependencies are silly executable tiled-hs |