From 727f2cbc5feb3cdd30df3c78f39ba4a58e6c4832 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Mon, 20 Sep 2021 20:41:31 +0200
Subject: [PATCH] simple parsing of local dependency paths
---
lib/LintWriter.hs | 1 +
lib/Properties.hs | 27 ++++++++++++++++-----------
lib/Types.hs | 16 +++++++---------
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
--
GitLab