From 727f2cbc5feb3cdd30df3c78f39ba4a58e6c4832 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Mon, 20 Sep 2021 20:41:31 +0200
Subject: 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
-- 
cgit v1.2.3